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. 维护工作表名称。

我们尝试了下面我们研究的这段代码，但它将所有工作簿和所有工作表中的所有数据组合到一张表中，并且数据组合不会删除标题等。请不要考虑下面的这段代码，因为我们是 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

Answer 2

我们面临运行时错误 1004 应用程序定义或对象定义错误

设置 rCopy=rcopy.offset(1).resize(rcopy.rows.count-1)