vorrei copiare il foglio 1 del singolo file presente in cartella raggruppandoli in un solo file "RIEPILOGO.xlsm".
Ho provato ad adattare una macro di un vecchio thread:
- Codice: Seleziona tutto
Public perc As String, Ws1 As String, f As String, WB1 As String
Sub ARCHIVIO()
Application.ScreenUpdating = False
Application.Calculation = xlManual
perc = ThisWorkbook.Path
If Dir(perc & "\ArchivioXls", vbDirectory) = "" Then
MkDir (perc & "\ArchivioXls")
End If
WB1 = ThisWorkbook.Name
Ws1 = "Foglio1"
Worksheets(Ws1).Select
Range("A1").Select
ElencoFile Direct:=perc, Estens:="*.xlsx*", Inicell:=ActiveCell
Columns("A:AZ").EntireColumn.AutoFit
Range("A1").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub ElencoFile(Direct As String, Estens As String, Inicell As Range)
Dim i As Integer, f As String
ChDir Direct
f = Dir(Estens)
If f = "" Then Exit Sub
While f <> ""
If f <> ThisWorkbook.Name Then
Application.Workbooks.Open perc & "\" & f
URF = Workbooks(f).Worksheets("Foglio1").Range("A" & Rows.Count).End(xlUp).Row
URR = Workbooks(WB1).Worksheets(Ws1).Range("A" & Rows.Count).End(xlUp).Row
Workbooks(f).ActiveSheet.Rows("1:" & URF).Copy Destination:=Workbooks(WB1).Worksheets(Ws1).Range("A" & URR + 1)
Workbooks(f).Close savechanges:=False
FileCopy perc & "\" & f, perc & "\ArchivioXls\" & f
Kill perc & "\" & f
End If
f = Dir
Wend
End Sub
ma il debug non gradisce:
Ho provato a girarci intorno rinunciando all'archiviazione:
- Codice: Seleziona tutto
Sub Unisci()
Dim MyPath As String
Dim MyName As String
Dim iRow As Long
Dim iCount As Long
Dim wksOrig As Workbook
Dim shOrig As Worksheet
Dim wksDest As Workbook
Dim shDest As Worksheet
Dim xRow As Long
Dim iCol As Integer
Application.ScreenUpdating = False
Set wksDest = ThisWorkbook
Set shDest = wksDest.Sheets("RIEPILOGO")
MyPath = ThisWorkbook.Path & "\*.xls" ' Imposta il percorso.
MyName = Dir(MyPath, vbNormal) ' Recupera la prima voce.
Do While MyName <> "" ' Avvia il ciclo.
If MyName <> wksDest.Name Then 'esclude se stesso
Set wksOrig = Workbooks.Open(MyName)
Set shOrig = wksOrig.Sheets(1) '<=== da verificare
With shDest
iRow = .Range("a" & Rows.Count).End(xlUp).Row + 1 'determina la prima riga vuota del foglio Destinazione
iCount = shOrig.Range("a" & Rows.Count).End(xlUp).Row ' determina l'ultima riga piena del foglio Origine
For xRow = 2 To iCount 'avvia il ciclo righe
For iCol = 1 To 10 ' avvia ciclo colonne
.Cells(iRow, iCol) = shOrig.Cells(xRow, iCol) 'scrive valori
Next
iRow = iRow + 1
Next
wksOrig.Close 'chiude il foglio Origine
End With
End If
MyName = Dir ' Legge la voce successiva.
Loop
Application.ScreenUpdating = True
Set wksDest = Nothing
Set shDest = Nothing
Set wksOrig = Nothing
Set shOrig = Nothing
End Sub
ma il debug protesta:
Cosa ovviamente sbaglio!!??!!
Esempio di file origine (xls) presenti in cartella: https://www.dropbox.com/s/cy93k9d73md1c4k/8%2C3%20forum.xls?dl=0
File RIEPILOGO.xlsm: https://www.dropbox.com/s/91uxt6fx6mjgsxd/Riepilogo.xlsm?dl=0
Grazie per l'aiuto
)
