从多个工作簿复制到单个工作簿 Excel VBA

Question

I have multiple workbooks in a single folder. All the workbooks share the same format and I wish to copy from the same range on the first worksheet in all workbooks and add this to a single worksheet of a newly created workbook.

The code so far:

Sub OpenAllCompletedFilesDirectory()
    Dim Folder As String, FileName As String
    Folder = "pathway..."
    FileName = Dir(Folder & "\*.xlsx")
    Do
        Dim currentWB As Workbook
        Set currentWB = Workbooks.Open(Folder & "\" & FileName)
        CopyDataToTotalsWorkbook currentWB

        FileName = Dir
    Loop Until FileName = ""
    
End Sub

Sub AddWorkbook()
    Dim TotalsWorkbook As Workbook
    Set TotalsWorkbook = Workbooks.Add
    outWorkbook.Sheets("Sheet1").Name = "Totals"
    outWorkbook.SaveAs FileName:="pathway..."
 
End Sub

Sub CopyDataToTotalsWorkbook(argWB As Workbook)
    Dim wsDest As Worksheet
    Dim lDestLastRow As Long
    Dim TotalsBook As Workbook
    Set TotalsBook = Workbooks.Open("pathway...")
    Set wsDest = TotalsBook.Worksheets("Totals")
    
    Application.DisplayAlerts = False
   
    lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
    argWB.Worksheets("Weekly Totals").Range("A2:M6").Copy
    wsDest.Range("A" & lDestLastRow).PasteSpecial
    
    Application.DisplayAlerts = True
    TotalsBook.Save
End Sub

This works - to a point. It does copy the correct ranges across and place the results one below another on the "Totals" worksheet of the "Totals" workbook, but it raises a 'Subscript out of range' error on:

argWB.Worksheets("Weekly Totals").Range("A2:M6").Copy

after data from the last workbook has been pasted. How can I tidy this code so that it works without error? I imagine there is scope to improve the code too.

Answer 1

I'd maybe do something like this.

Note you can just open the summary workbook once before looping over the files.

Sub SummarizeFiles()
    'Use `Const` for fixed values
    Const FPATH As String = "C:\Test\"      'for example
    Const TOT_WB As String = "Totals.xlsx"
    Const TOT_WS As String = "Totals"
    
    Dim FileName As String, wbTot As Workbook, wsDest As Worksheet
    
    'does the "totals" workbook exist?
    'if not then create it, else open it
    If Dir(FPATH & TOT_WB) = "" Then
        Set wbTot = Workbooks.Add
        wbTot.Sheets(1).Name = TOT_WS
        wbTot.SaveAs FPATH & TOT_WB
    Else
        Set wbTot = Workbooks.Open(FPATH & TOT_WB)
    End If
    Set wsDest = wbTot.Worksheets(TOT_WS)
        
    FileName = Dir(FPATH & "*.xlsx")
    Do While Len(FileName) > 0
        If FileName <> TOT_WB Then  'don't try to re-open the totals wb
            With Workbooks.Open(FPATH & FileName)
                .Worksheets("Weekly Totals").Range("A2:M6").Copy _
                    wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
                .Close False 'no changes
            End With
        End If
        wbTot.Save
        FileName = Dir 'next file
    Loop
    
End Sub