On 1 Dic, 09:02, "Mauro Gamberini"
allego di seguito la macro funzionante approntata da Mauro Gamberini
che ringrazio e che potrebbe tornare utile per casi simili
Questa macro che va messa nel file dove recuperi i dati, apre tutti i
files di Excel che sono nella cartella: tuaCartella, copia i dati del
Foglio1 di ciascun file da A1 a H(n), saltando le colonne F e J e le
incolla nel foglio DATA ENTRY del file dove hai la macro:
Public Sub m()
On Error GoTo RigaErrore
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim wrk As Workbook
Dim sh As Worksheet
Dim shStorico As Worksheet
Dim wkStorico As Workbook
Dim lUltRiga As Long
Dim lRiga As Long
Dim sPath As String
With Application
.ScreenUpdating = False
.Calculation = xlManual
.StatusBar = "Sto eseguendo: Sub m()"
End With
sPath = "C:\tuaCartella\"
Set wkStorico = ThisWorkbook
Set shStorico = wkStorico.Worksheets("DATA ENTRY")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(sPath)
For Each objFile In objFolder.Files
If Right(objFile.Name, 3) = "xls" _
Or Right(objFile.Name, 4) = "xlsx" _
Or Right(objFile.Name, 4) = "xlsm" Then
Set wrk = Workbooks.Open(sPath & objFile.Name)
With wrk
Set sh = .Worksheets("Foglio1")
End With
With shStorico
lUltRiga = shStorico.Range("A"
& .Rows.Count).End(xlUp).Row + 1
End With
With sh
lRiga = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:E" & lRiga).Copy
shStorico.Range("A" & lUltRiga).PasteSpecial
xlPasteValues
.Range("G1:H" & lRiga).Copy
shStorico.Range("G" & lUltRiga).PasteSpecial
xlPasteValues
End With
wrk.Close
End If
Next
shStorico.Range("A1").Select
RigaChiusura:
Application.CutCopyMode = False
Set sh = Nothing
Set wrk = Nothing
Set shStorico = Nothing
Set wkStorico = Nothing
Set objFile = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
.StatusBar = ""
End With
Exit Sub
RigaErrore:
MsgBox Err.Number & vbNewLine & Err.Description
Resume RigaChiusura
End Sub