问循环遍历子文件夹中的Excel文件，并将数据复制并粘贴到一个工作表中

EN

Sub LoopCopyPasteSubfoldersIII()

Dim fso As Object
Dim wb As Object
Dim folder As Object
Dim subfolder As Object
Dim MyPath As String
Dim MyFile As String
Dim FdrPicker As FileDialog
Dim wba As Workbook
Dim wbn As String

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set FdrPicker = 
Application.FileDialog(msoFileDialogFolderPicker)

With FdrPicker
.Title = "Select a Target Folder"
.AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    MyPath = .SelectedItems(1) & "\"
End With

NextCode:
'in case of cancel
MyPath = MyPath
If MyPath = "" Then GoTo ResetSettings Else

Dim NewWB As Workbook
Set NewWB = Workbooks.Add

NewWB.SaveAs Filename:="C:\Users\405458\Downloads\Compilation.xlsx", 
FileFormat:=xlWorkbookNormal

Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.getfolder(MyPath)

For Each subfolder In folder.subfolders

For Each wb In subfolder.Files
    If fso.GetExtensionName(wb.Path) = "xlsx" Then
        wbn = fso.GetAbsolutePathName(wb)
        Set wba = Workbooks.Open(Filename:=wbn)

   ActiveWorkbook.Worksheets(1).Range("A1:M1").Select
            Range(Selection, Selection.End(xlDown)).Copy
            For Each cell In Workbooks("Compilation").Worksheets("Sheet1").Columns(1).Cells
                If IsEmpty(cell) = True Then
                   cell.PasteSpecial Paste:=xlPasteValues
                'exit when value pasted to the first empty row
                Exit For
                Else
                End If
            Next cell
        wba.Close False
        NewWB.Save
    End If
Next wb

Next subfolder

'reset settings to default
ResetSettings:

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

Sub LoopCopyPasteSubfoldersIII()

Dim fso As Object
Dim wb As Object
Dim folder As Object
Dim subfolder As Object
Dim MyPath As String
Dim MyFile As String
Dim FdrPicker As FileDialog
Dim wba As Workbook

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set FdrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FdrPicker
.Title = "Select a Target Folder"
.AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    MyPath = .SelectedItems(1) & "\"
End With

NextCode:
'in case of cancel
MyPath = MyPath
If MyPath = "" Then GoTo ResetSettings Else

Dim NewWB As Workbook
Set NewWB = Workbooks.Add

NewWB.SaveAs Filename:="C:\Users\405458\Downloads\Compilation.xlsx", 
FileFormat:=xlWorkbookNormal

Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.getfolder(MyPath)

For Each subfolder In folder.subfolders

For Each wb In subfolder.Files
    If fso.GetExtensionName(wb.Path) = "*.xls*" Then
        Set wba = Workbooks.Open(wb.Path & "\" & wb.FullName, , True)
            wba.Worksheets(1).Range("A1:M20").Copy
            For Each cell In 
Workbooks("Compilation").Worksheets("Sheet1").Columns(1).Cells
                If IsEmpty(cell) = True Then
                   cell.PasteSpecial Paste:=xlPasteValues
                'exit when value pasted to the first empty row
                End If
            Exit For

            Next cell
        wba.Close False
        NewWB.Save
    End If
Next wb

Next subfolder

'reset settings to default
ResetSettings:

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub