从多个工作簿复制到单个工作簿 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

粘贴最后一个工作簿中的数据后。 如何整理此代码以使其正常工作？ 我想还有改进代码的空间。

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