Loop through Excel files in subfolders and copy and paste data to one sheet - vba

Question

I'm trying to loop through all Excel files in subfolders of a folder designated by a user and copy and paste data to a new workbook named "Compilation". This code works up to creating and saving a new workbook but data wouldn't copy and paste to the workbook.
Can anyone please help?
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

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

Answer 2

This is finalized code that loops through all subfolders in a folder selected by user and copy and paste data in any Excel files in subfolders to a new workbook.
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