将多个工作簿合并到一个 Excel 工作簿中

Question

我想将多个工作簿的第一张合并到一个主工作簿中。 数据始终以相同的方式结构化。 除此之外，我想在我的主工作簿中添加一张额外的表格，其中汇总了所有数据（将每张表格的所有数字相加，例如 1+1+1=3）。

到目前为止，我从这段代码开始。 然而，我不知道如何在 VBA 中用不同的工作簿进行总结（这就是为什么它没有包含在代码中）

在此先感谢各位！

'Defining
Dim wb As Workbook
Dim ws As Worksheet
Dim directory As String
Dim myFiles As String
Dim targetwb As Workbook
Set targetwb = ThisWorkbook

Application.ScreenUpdating = False

directory = "C:\Dokumente\"
myFiles = Dir(directory & "*.xlsx")

'Loop through all files in a folder until DIR cannot find anymore

Do While myFiles <> ""

'Open Workbooks one by one 'Do i really have to use the "set command"???
Set wb = Workbooks.Open(Filename:=directory & myFiles)

'The actual action

'Countries:

'Brazil:

If wb.Name = "Brazil*" Then
Worksheets("Status Overview").Copy ThisWorkbook.Worksheets("Brazil")
End If

'Kosovo:

If wb.Name = "Kosovo*" Then
Worksheets("Status Overview").Copy ThisWorkbook.Worksheets("Kosovo")
End If

'United States:

If wb.Name = "United States*" Then
Worksheets("Status Overview").Copy ThisWorkbook.Worksheets("United States")
End If

Workbooks(myFiles).Close

myFiles = Dir

Loop

Application.ScreenUpdating = True```

Answer 1

在具有一个工作表名称摘要的工作簿中运行此操作。

Option Explicit

Sub Summarize()

    Const FOLDER = "C:\Dokumente\"
    Const WS_NAME = "Status Overview"
   
    'Defining
    Dim wbIn As Workbook, wb As Workbook, ws As Worksheet, ar, s
    Dim filename As String, msg As String
    Dim copied As Collection
    Set copied = New Collection

    ar = Array("Brazil", "Kosovo", "United States")
    Set wb = ThisWorkbook
    
    'Application.ScreenUpdating = False
    filename = Dir(FOLDER & "*.xlsx")
    Do While filename <> ""
        For Each s In ar
            If LCase(filename) Like LCase(s) & "*" Then
                Set wbIn = Workbooks.Open(FOLDER & filename, True, True) ' update links, read only
                wbIn.Sheets(WS_NAME).Copy after:=wb.Sheets(wb.Sheets.Count)
                wbIn.Close False
                wb.Sheets(wb.Sheets.Count).Name = s
                copied.Add s
                msg = msg & vbCrLf & s
            End If
        Next
        filename = Dir
    Loop

    ' build =SUM() formula
    Dim f As String, sep As String, rng As Range
   
    f = "=SUM("
    For Each s In copied
        f = f & sep & "'" & s & "'!RC"
        sep = ","
    Next
    f = f & ")"

   ' range to summate on summary sheet
    Set rng = wb.Sheets("Summary").Range("A10:E20")

    ' apply sum formula to range
    rng.FormulaR1C1 = f
   
    'Application.ScreenUpdating = True
    MsgBox "Imported :" & msg, vbInformation

End Sub