VBA：将多个工作簿（带有多个工作表）合并到一个工作簿中，数据一个在另一个下面

Question

我是 VBA 的新手。 我们正在努力做到以下几点：

1. 我们有多个工作簿，有 10 个工作表。 每个工作表都有一个特定的名称。 例如，我们可以将它们称为 Sheet 1 到 Sheet 10。
   （虽然它们实际上被称为 QB-4.1 DA、QB-4.2 DA、QB-4.3 DA 等）
2. 所有工作簿中所有 Sheet1 的格式都相同，所有工作簿中所有 Sheet2 的格式都相同等。

我们想编写一个 VBA 代码，它将在名为 Output.xlsm 的单独工作簿中执行以下操作

1. 在 Output.xlsm-> Sheet1 中：

   • 从 Workbook1->Sheet1 复制所有数据，包括标题。

   • 从 Workbook2->Sheet1 复制所有数据，不包括标题。

   • 从 Workbook3->Sheet1 复制所有数据，不包括标题。 直到工作簿 n。

2. Output.xlsm 中的所有其他工作表与上述相同。 即，Output.xlsm-> Sheet2：

   • 从 Workbook1->Sheet2 复制所有数据，包括标题。

   • 从 Workbook2->Sheet2 复制所有数据，不包括标题。

   • 从 Workbook3->Sheet2 复制所有数据，不包括标题。 直到工作簿 n。

3. 维护 SheetNames。

我们在我们研究的下面尝试了这段代码，但它将所有工作簿和所有工作表中的所有数据合并到一张表中，并且数据的合并不会删除标题等。由于我们是 VBA 初学者，请在下面打折这段代码。

 Sub simpleXlsMerger()
    
    Dim bookList As Workbook
    
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
    
    Application.ScreenUpdating = False
    
    Set mergeObj = CreateObject("Scripting.FileSystemObject")
    
    'change folder path of excel files here
    
    Set dirObj = mergeObj.Getfolder("C:\consolidated\")
    
    Set filesObj = dirObj.Files
    
    For Each everyObj In filesObj
    
        Set bookList = Workbooks.Open(everyObj)
    
        Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy
    
        ThisWorkbook.Worksheets(1).Activate
    
        Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
    
        Application.CutCopyMode = False
    
        bookList.Close
    
    Next
    
    End Sub

我们试图研究 StackOverFlow 中的许多帖子。 请您指导我们如何完成此操作。

示例工作簿：

• 工作簿1

• 工作簿2

• 输出.xlsm

Answer 1

你能试试这个吗？

我没有查看您的文件，因此可能需要进行一些调整。

Sub simpleXlsMerger()
    
Dim bookList As Workbook, bFirst As Boolean, ws As Worksheet, wsO As Worksheet
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Dim rCopy As Range

Application.ScreenUpdating = False

Set mergeObj = CreateObject("Scripting.FileSystemObject")

'change folder path of excel files here
Set dirObj = mergeObj.Getfolder("C:\consolidated\")
Set filesObj = dirObj.Files

For Each everyObj In filesObj
    Set bookList = Workbooks.Open(everyObj)
    For Each ws In bookList.Worksheets
        If Not bFirst Then
            Set wsO = ThisWorkbook.Worksheets.Add()
            wsO.Name = ws.Name
            Set rCopy=ws.range("A1").currentregion
            'Set rCopy = ws.Range("A1", ws.Range("IV" & Rows.Count)).End(xlUp)
        Else
            Set wsO = ThisWorkbook.Worksheets(ws.Name)
            Set rCopy=ws.range("A1").currentregion
            Set rCopy=rcopy.offset(1).resize(rcopy.rows.count-1)
            'Set rCopy = ws.Range("A2", ws.Range("IV" & Rows.Count)).End(xlUp)
        End If
        rCopy.Copy wsO.Range("A" & Rows.Count).End(xlUp)(2)
    Next ws
    bookList.Close
    bFirst = True
Next

End Sub