VBA：将多个工作簿（带有多个工作表）组合成一个工作簿，数据一个在另一个之下

Posted 2023-03-27

【中文标题】VBA：将多个工作簿（带有多个工作表）组合成一个工作簿，数据一个在另一个之下

【英文标题】：VBA : Combine multiple Workbooks(with mutiple Worksheets) into One Workbook with Data One Below The Other

【发布时间】：2021-01-04 17:36:47

【问题描述】：

我是 VBA 新手。我们正在尝试执行以下操作：

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

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

在 Output.xlsm-> Sheet1 中：

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

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

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

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

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

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

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

维护工作表名称。

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

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

示例工作簿：

Workbook1

Workbook2

Output.xlsm

【问题讨论】：

输出文件中是否已经存在工作表？

@James Z：嗨，詹姆斯。感谢您向我展示编辑后的版本。看起来好多了。今后将以该格式格式化数据。

@SJR：嗨 SJR：关于您的问题：输出文件中不存在工作表。宏可以写入输出文件并运行。并且所有工作簿中的数据，都可以合并到输出文件中。

您的代码的问题是您没有在结果文件中创建单独的工作表，也没有删除标题行。如果你还在看，我稍后再看。

@SJR：是的，该代码无法完成这项工作。这是我们正在研究的东西，但它不适合，因为它是为不同的要求而构建的。是的，我们仍在寻找这个 SJR。

【参考方案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

【讨论】：

它目前正在创建完全按照原始名称命名的工作表。

这是否意味着它有效？顺便说一句，您不应该对 IV 等引用进行硬编码，因为 Excel 现在在最近版本中超出了该列。

它复制工作表名称。数据尚未复制...好的，关于硬编码的注意事项。

根据您附加的工作簿，我在上面做了一些更改，您可以再试一次吗？

非常感谢 SJR！这非常有效。真的很高兴你能解决这个问题。注意安全。再次感谢。