從多個工作簿復制到單個工作簿 Excel VBA

Question

我在一個文件夾中有多個工作簿。 所有工作簿共享相同的格式，我希望從所有工作簿的第一個工作表上的相同范圍復制並將其添加到新創建的工作簿的單個工作表中。

到目前為止的代碼：

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

這有效 - 在一定程度上。 它確實復制了正確的范圍並將結果放在另一個下方的“總計”工作簿的“總計”工作表中，但它會引發“下標超出范圍”錯誤：

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

粘貼上一個工作簿中的數據后。 如何整理此代碼以使其正常工作？ 我想還有 scope 來改進代碼。

Answer 1

我可能會做這樣的事情。

請注意，您可以在循環文件之前打開摘要工作簿一次。

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