Copying from multiple workbooks to single workbook Excel VBA-CodePudding

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.

CodePudding user response：

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