多个excel工作簿合并_Excel应用实践14：合并多个工作簿中的数据—示例3

学习Excel技术，关注微信公众号：

excelperfect

要合并工作簿的情形有许多种，但最终的目的只有一条，将繁锁的手工操作自动化，让程序快速帮助我们完成这些重复的工作。

本例中，要合并的工作簿放置在同一文件夹中，为方便描述，这些工作簿名称和其要合并的数据工作表如下(假设要合并的工作簿有3个)：

“工作簿1.xlsm”中的工作表“完美Excel”

“工作簿2.xlsm”中的工作表“excelperfect”

“工作簿3.xlsm”中的工作表“微信公众号”

这些工作表都有相同的列标题，但是数据行数不同。要求：

1.将这些工作簿中的工作表合并到名为“合并.xlsm”工作簿的工作表“数据”中。

2.在“合并.xlsm”工作簿工作表“数据”的列F中，放置对应行数据来源工作簿工作表名，例如如果数据行2中的数据来自工作表“完美Excel”，则在该行列F单元格中输入“完美Excel”。

3.要合并的工作簿工作表，例如工作簿1.xlsm中的“完美Excel”数据发生变化后，在“合并.xlsm”工作表中运行代码后，会清除“数据”工作表中原先的数据并重新合并上述工作簿中的工作表数据。

合并工作簿的效果如下图1所示。

图1

在“合并.xlsm”工作簿中，打开VBE，插入标准模块，输入下面的代码：

Sub CombineWorkbook()

    Dim wb As Workbook

    Dim i As Long

    Dim j As Long

    Dim curRow As Long

    Dim lastRow As Long

    '关闭屏幕更新

    Application.ScreenUpdating = False

    '清除工作表中的数据

    Workbooks("合并.xlsm").Worksheets("数据").Cells.ClearContents

    '添加列标题

    Workbooks("合并.xlsm").Worksheets("数据").Range("A1:F1") =Array("编号", "产品名", "规格", "数量", "", "工作表名")

    '从第2行开始

    curRow = 2

     '遍历工作簿

    For i = 1 To 3

        '打开工作簿

        Set wb = Workbooks.Open("工作簿" & i & ".xlsm")

        Select Case i

            Case 1

                lastRow = Workbooks("工作簿1.xlsm").Worksheets("完美Excel").Cells(Rows.Count,1).End(xlUp).Row

                Workbooks("工作簿1.xlsm").Worksheets("完美Excel").Range("A2:D"& lastRow).Copy _

                Workbooks("合并.xlsm").Worksheets("数据").Cells(curRow, 1)

                For j = 2 To lastRow

                    Workbooks("合并.xlsm").Worksheets("数据").Cells(curRow, 6) = "完美Excel"

                    curRow = curRow + 1

                Next

            Case 2

                lastRow = Workbooks("工作簿2.xlsm").Worksheets("excelperfect").Cells(Rows.Count,1).End(xlUp).Row

                Workbooks("工作簿2.xlsm").Worksheets("excelperfect").Range("A2:D"& lastRow).Copy _

                Workbooks("合并.xlsm").Worksheets("数据").Cells(curRow, 1)

                For j = 2 To lastRow

                    Workbooks("合并.xlsm").Worksheets("数据").Cells(curRow, 6) ="excelpefect"

                    curRow = curRow + 1

                Next

            Case 3

                lastRow = Workbooks("工作簿3.xlsm").Worksheets("微信公众号").Cells(Rows.Count,1).End(xlUp).Row

                Workbooks("工作簿3.xlsm").Worksheets("微信公众号").Range("A2:d" &lastRow).Copy _

                Workbooks("合并.xlsm").Worksheets("数据").Cells(curRow, 1)

                For j = 2 To lastRow

                    Workbooks("合并.xlsm").Worksheets("数据").Cells(curRow, 6) = "微信公众号"

                    curRow = curRow + 1

                Next

        End Select

        '关闭工作簿

        Workbooks("工作簿" & i &".xlsm").Close

    Next i

    '恢复屏幕更新

    Application.ScreenUpdating = True

End Sub

上面代码的图片版如下：

也可以使用下面的代码来合并工作簿：

Sub CombineWorkbook()

    Dim wbwsArr

    Dim wb As Workbook

    Dim i As Long

    Dim lastCol As Long

    Dim lastRow As Long

    Dim ws As Worksheet

    Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Worksheets("数据")

    ws.Cells.ClearContents

    ws.Range("A1:F1") = Array("编号", "产品名", "规格", "数量", "", "工作表名")

    wbwsArr = Array("工作簿1", "完美Excel", "工作簿2", "excelperfect","工作簿3", "微信公众号")

    For i = LBound(wbwsArr) To UBound(wbwsArr)- 1 Step 2

        '打开工作簿

        Set wb =Workbooks.Open(ThisWorkbook.Path & "\" & wbwsArr(i) &".xlsm")

        '复制数据

        wb.Worksheets(wbwsArr(i +1)).UsedRange.Offset(1).Copy _

        ThisWorkbook.Worksheets("数据").Cells(Rows.Count,1).End(xlUp).Offset(1)

        '输入工作表名

        ws.Range("F" &ws.Cells(Rows.Count, 6).End(xlUp).Offset(1).Row & ":F" &ws.Cells(Rows.Count, 1).End(xlUp).Row).Value = wbwsArr(i + 1)

        '关闭工作簿

        wb.Close False

    Next i

    Application.ScreenUpdating = True

End Sub

上面代码的图片版如下：