Перебирайте файлы Excel в подпапках, копируйте и вставляйте данные на один лист

Question

Я пытаюсь перебрать все файлы Excel в подпапках папки, указанной пользователем, и скопировать и вставить данные в новую рабочую книгу с именем «Компиляция».Этот код работает до создания и сохранения новой рабочей книги, но данные не будут копироваться и вставляться в рабочую книгу.

Может кто-нибудь помочь, пожалуйста?

Sub LoopCopyPasteSubfolders()

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

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
If MyPath = "" Then GoTo ResetSettings Else

Dim NewWB As Workbook
Set NewWB = Workbooks.Add

ActiveWorkbook.SaveAs Filename:="C:\Batch\Compilation.xlsx", FileFormat:=xlWorkbookNormal

Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.getfolder(MyPath)
Set subfolder = folder.subfolders
For Each subfolder In folder.subfolders
Set wb = subfolder.Files

 For Each wb In subfolder.Files
    If fso.GetExtensionName(wb.Path) = "*.xls*" Then
    Workbooks.Open wb, ReadOnly:=True
    Range("A1:M1").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
    Next cell
End If

Next wb

Next subfolder  

'reset settings to default    
ResetSettings:

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

End Sub

Answer 1

Это окончательный код, который проходит по всем подпапкам в папке, выбранной пользователем, и копирует и вставляет данные из любых файлов Excel в подпапках в новую рабочую книгу.

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

Answer 2

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