学习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
上面代码的图片版如下：