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

上面代码的图片版如下:

原文发布于微信公众号 - 完美Excel(excelperfect)

原文发表时间:2019-06-03

本文参与腾讯云自媒体分享计划,欢迎正在阅读的你也加入,一起分享。

发表于

我来说两句

0 条评论
登录 后参与评论

扫码关注云+社区

领取腾讯云代金券