Copy multiple ranges of different length in a loop that searches every Excel file in subfolders and paste on new master worksheet

Question

How do I copy/paste multiple ranges? The code returns the cell A1.

What I need:

• 1- Search and open all Excel files in a folder with subfolders
• 2- Copy specific cells ("A1", "C7:L7", "C8:L8", "C9:L9", "K10", "L10" etc)
• 3- Paste all those copied cells from the loop in 1 new folder

Here is my code: (from multiple sources online)

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
Dim range1 As Range
Dim range2 As Range
Dim range3 As Range
Dim range4 As Range
Dim multipleRange As Range

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\15813\Desktop\Bickerdike 
data\FAIT\2016-excel\ok123.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)
    
   ' If MyFile = "compilation4.xlsm" Then
   '     Exit Sub
   ' With wb.Sheets(1)
         '   rngArr = Array("A1", "C7", "D7", "E7", "F7", "G7", 
"H7", "I7", "J7", "K7", "L7", "C8", "D8", "E8", "F8", "G8", 
"H8", "I8", "J8", "K8", "L8", "C9", "D9", "E9", "F9", "G9", 
"H9", "I9", "J9", "K9", "L9", "K10", "L10", "R7", "S7", "R8", 
"S8", "R9", "S9")
            '"N7", "O7", "P7", "Q7"

         '   j = 0
         '   For i = LBound(rngArr) To UBound(rngArr)
         '       j = j + 1
         '       .Range(rngArr(i)).Copy 
Workbooks("compilation4.xlsm").Sheets(1).Cells(Rows.Count, 
j).End(xlUp)(2)
                          
        'Next
     '   End With
   ' wb.Close
    'MyFile = Dir
   
 
    'Set rngArr = Array("A1", "C7", "D7", "E7", "F7", "G7", 
"H7", "I7", "J7", "K7", "L7", "C8", "D8", "E8", "F8", "G8", 
"H8", "I8", "J8", "K8", "L8", "C9", "D9", "E9", "F9", "G9", 
"H9", "I9", "J9", "K9", "L9", "K10", "L10", "R7", "S7", "R8", 
"S8", "R9", "S9")
      'rngArr.Copy
      'Set newbook = Workbooks.Add
      'Range("A1").PasteSpecial
 ActiveWorkbook.Worksheets(1).Range("A1, C7:L7, C8:L8").Select
         'Set range1 = Sheets(1).Range("A1")
         'Set range2 = Sheets(1).Range("C7:L7")
         'Set range3 = Sheets(1).Range("C8:L8")
         'Set range4 = Worksheets(1).Range("C9:L9")
         'Set multipleRange = Union(range1, range2, range3)
         
        ActiveWorkbook.Worksheets(1).Range("A1").Copy
         'ThisWorkbook.Sheets(1).Range("C7:L7").Copy
         'ThisWorkbook.Sheets(1).Range("C8:L8").Copy
         'Range(Selection, Selection.End(xlDown)).Copy
        'marche pas quand c pas continuous
         'Range("A1:AI1").Copy
                
                 For Each cell In 
Workbooks("ok123").Worksheets("Sheet1").Columns(1).Cells
           If IsEmpty(cell) = True Then
               cell.PasteSpecial Paste:=xlPasteAll
            
            '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 1

It's not clear how the pasted data should be arranged in your new summary file, but here's an example which copies it all to one line per file (assuming no source ranges have >1 row)

Sub LoopCopyPasteSubfoldersIII()
    
    Dim allFiles As Collection, f, wb As Workbook, newWb As Workbook
    Dim rngArr, addr, rng As Range, rngDest As Range, MyPath As String, n As Long
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Target Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        MyPath = .SelectedItems(1) & "\"
    End With
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Set allFiles = GetMatches(MyPath, "*.xlsx")   'find all matching files
    If allFiles.Count = 0 Then Exit Sub           'no files found...
    
    Set newWb = Workbooks.Add()
    newWb.SaveAs Filename:="C:\Users\15813\Desktop\Bickerdike data\" & _
                 "FAIT\2016-excel\ok123.xlsx", FileFormat:=xlWorkbookNormal
    
    Set rngDest = newWb.Worksheets(1).Range("A2") 'start paste range
    
    rngArr = Array("A1", "C7", "D7", "E7", "F7", "G7", _
                    "H7", "I7", "J7", "K7", "L7", "C8", "D8", "E8", "F8", "G8", _
                    "H8", "I8", "J8", "K8", "L8", "C9", "D9", "E9", "F9", "G9", _
                    "H9", "I9", "J9", "K9", "L9", "K10", "L10", "R7", "S7", "R8", _
                    "S8", "R9", "S9")
    
    For Each f In allFiles
        Set wb = Workbooks.Open(f.path)
        n = 0 'reset offset
        For Each addr In rngArr                  'loop the source range addresses
            Set rng = wb.Sheets(1).Range(addr)   'get this source range
            rng.Copy Destination:=rngDest.Offset(0, n)
            n = n + rng.Columns.Count            'increment offset by number of columns pasted
        Next addr
        Set rngDest = rngDest.Offset(1, 0)       'next destination row
        wb.Close savechanges:=False
    Next f

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

End Sub


'Return a collection of file objects given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr, fpath
    Dim colFiles As New Collection
    Dim colSub As New Collection
    
    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder
    
    Do While colSub.Count > 0
        
        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1
        
        If subFolders Then
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.path
            Next subFldr
        End If
        
        fpath = fldr.path
        If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
        f = Dir(fpath & filePattern) 'Dir is faster...
        Do While Len(f) > 0
            colFiles.Add fso.getfile(fpath & f)
            f = Dir()
        Loop
    Loop
    Set GetMatches = colFiles
End Function