Excel·VBA合并工作簿的实现示例

1，合并文件夹下所有工作簿

适用将所有工作簿中所有工作表复制到1个新建工作簿中，不修改数据，原本一共有多少个工作表，合并后就有多少个工作表如果存在同名工作表，复制后工作表名称会自动添加序号，如Sheet1 (2)

Sub 合并文件夹下所有工作簿()
\’文件夹下所有工作簿wb所有工作表ws合并为一个新工作簿（但不含子文件夹），不修改数据
Dim write_wb As Workbook, wb As Workbook, sht As Worksheet, file_path$, file_name$
file_path = \”E:\\测试\\拆分表\\\” \’待合并工作簿所在的文件夹
file_name = Dir(file_path & \”*.xlsx\”)
Application.ScreenUpdating = False \’关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False \’不显示警告信息
Set write_wb = Workbooks.Add \’新建工作簿，合并文件
Do While file_name <> \”\”
Set wb = Workbooks.Open(file_path & file_name)
For Each sht In wb.Worksheets
sht.Copy After:=write_wb.Sheets(write_wb.Sheets.Count)
Next
wb.Close (False)
file_name = Dir \’下一个文件名
Loop
\’保存文件
save_file = file_path & \”合并表.xlsx\”
write_wb.SaveAs filename:=save_file
write_wb.Close (False)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

1.1，合并且建立超链接目录

Sub 合并文件夹下所有工作簿并建立目录()
\’文件夹下所有工作簿wb所有工作表ws合并为一个新工作簿（但不含子文件夹），不修改数据，并建立目录超链接
Dim write_wb As Workbook, wb As Workbook, list_ws As Worksheet, sht As Worksheet
Dim fso As Object, file_path$, file_name$, full_name$, newname$, w&
file_path = \”E:\\测试\\拆分表\\\” \’待合并工作簿所在的文件夹
file_name = Dir(file_path & \”*.xlsx\”)
Application.ScreenUpdating = False \’关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False \’不显示警告信息
Set write_wb = Workbooks.Add \’新建工作簿，合并文件
Set list_ws = write_wb.Worksheets(1): list_ws.Name = \”目录\”
list_ws.Cells(1, 1) = \”目录(原工作簿名-工作表名)\”: list_ws.Cells(1, 2) = \”超链接\”: w = 1
Set fso = CreateObject(\”Scripting.FileSystemObject\”)
Do While file_name <> \”\”
Set wb = Workbooks.Open(file_path & file_name)
For Each sht In wb.Worksheets
sht.Copy After:=write_wb.Sheets(write_wb.Sheets.Count)
full_name = fso.GetBaseName(file_name) & \”-\” & sht.Name \’原工作簿名-工作表名
\’write_wb.Sheets(write_wb.Sheets.Count).Name = full_name \’可对复制的ws重命名
w = w + 1: list_ws.Cells(w, 1) = full_name: newname = write_wb.Sheets(write_wb.Sheets.Count).Name
list_ws.Hyperlinks.Add anchor:=list_ws.Cells(w, 2), Address:=\”\”, SubAddress:=\”\’\” & newname & \”\’!a1\”, TextToDisplay:=newname
Next
wb.Close (False)
file_name = Dir \’下一个文件名
Loop
\’保存文件
list_ws.Columns(1).AutoFit \’列宽自适应
save_file = file_path & \”合并表.xlsx\”
write_wb.SaveAs filename:=save_file
write_wb.Close (False)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

举例

合并《Excel·VBA按列拆分工作表》，sub2拆分后的工作表

并且每个工作簿中的工作表复制1个副本（1个地名表1个Sheet1表），这样就有5个工作簿各含2个工作表工作簿合并且建立超链接目录结果

2，合并工作簿中所有工作表

对工作簿中相同格式的工作表进行合并，汇总所有工作表，保存在工作簿最前

2.1，纵向合并

Sub 合并工作簿中所有工作表_纵向()
\’当前工作簿wb所有工作表ws合并保存至新建工作表（插入最前），但之前ws不修改（工作表格式相同）
Dim wb, ws, title_row, end_row, copy_title, i
\’——————–参数填写：title_row，数字，第1行为1向下递增；end_row，数字
title_row = 1 \’表头行数，仅复制1次；如果为0，则表示没有表头或表头每次都复制
end_row = 0 \’表尾行数，不参与合并
Set wb = Application.ActiveWorkbook \’当前工作簿即为待合并工作簿
Set ws = wb.Worksheets.Add(before:=Sheets(1)) \’最前添加新sheet，即为合并工作表
ws.Name = \”合并表\”
If title_row > 0 Then copy_title = True Else copy_title = False \’是否复制表头
If title_row < 0 Then Debug.Print \”title_row参数错误，必须为>=0的整数\”: Exit Sub
Application.ScreenUpdating = False \’关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False \’不显示警告信息
\’遍历，复制表体
For i = 1 To Worksheets.count:
If Worksheets(i).Name <> ws.Name Then
If copy_title = True Then \’复制表头，仅执行1次
Worksheets(i).Rows(1 & \”:\” & title_row).Copy ws.Range(\”A1\”)
copy_title = False
End If
\’首行为空，会导致后续数据被覆盖
If WorksheetFunction.CountA(ws.Rows(1)) = 0 Then ws.Rows(1).Delete
write_row = ws.UsedRange.Rows.count + 1 \’合并工作表的第一个空行写入
sheet_row = Worksheets(i).UsedRange.Rows.count
Worksheets(i).Rows(title_row + 1 & \”:\” & sheet_row – end_row).Copy ws.Range(\”A\” & write_row)
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

举例

合并《Excel·VBA按列拆分工作表》，sub1拆分后的工作表

合并参数：title_row = 1，end_row = 0

2.2，横向合并

Sub 合并工作簿中所有工作表_横向()
\’当前工作簿wb所有工作表ws合并保存至新建工作表（插入最前），但之前ws不修改（工作表格式相同）
Dim ws As Worksheet, sht As Worksheet, write_col&
Application.ScreenUpdating = False \’关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False \’不显示警告信息
With ActiveWorkbook
Set ws = .Worksheets.Add(before:=Sheets(1)) \’最前添加新sheet，即为合并工作表
ws.Name = \”合并表\”
For Each sht In .Worksheets
If sht.Name <> ws.Name Then
\’首列为空时，会导致后续数据被覆盖
If WorksheetFunction.CountA(ws.Columns(1)) = 0 Then ws.Columns(1).Delete
write_col = ws.UsedRange.Columns.Count + 1
sht.UsedRange.Copy ws.Cells(1, write_col)
End If
Next
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

举例

合并前

合并后

3，合并文件夹下所有工作簿中所有工作表

对相同格式的工作簿进行合并，汇总所有工作表，保存为单独工作簿

Sub 合并文件夹下所有工作簿中所有工作表()
\’文件夹下所有工作簿wb所有工作表ws合并保存至新建工作表（但不含子文件夹），但不修改原数据（工作表格式相同）
Dim wb, ws, title_row, end_row, copy_title, file_path, file_name, save_file, i
\’——————–参数填写：title_row，数字，第1行为1向下递增；end_row，数字；file_path，合并文件夹
title_row = 1 \’表头行数，仅复制1次；如果为0，则表示没有表头或表头每次都复制
end_row = 0 \’表尾行数，不参与合并
file_path = \”E:\\测试\\拆分表\\\” \’待合并工作簿所在的文件夹
file_name = Dir(file_path & \”*.xlsx\”)
If title_row > 0 Then copy_title = True Else copy_title = False \’是否复制表头
If title_row < 0 Then Debug.Print \”title_row参数错误，必须为>=0的整数\”: Exit Sub
Application.ScreenUpdating = False \’关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False \’不显示警告信息
Workbooks.Add \’新建工作表
Set ws = ActiveSheet
ws.Name = \”合并表\”
Do While file_name <> \”\”
Set wb = Workbooks.Open(file_path & file_name)
For i = 1 To Worksheets.count:
If copy_title = True Then \’复制表头，仅执行1次
wb.Worksheets(i).Rows(1 & \”:\” & title_row).Copy ws.Range(\”A1\”)
copy_title = False
End If
\’首行为空，会导致后续数据被覆盖
If WorksheetFunction.CountA(ws.Rows(1)) = 0 Then ws.Rows(1).Delete
write_row = ws.UsedRange.Rows.count + 1 \’合并工作表的第一个空行写入
sheet_row = wb.Worksheets(i).UsedRange.Rows.count
wb.Worksheets(i).Rows(title_row + 1 & \”:\” & sheet_row – end_row).Copy ws.Range(\”A\” & write_row)
Next
wb.Close (False)
file_name = Dir \’下一个文件名
Loop
\’保存文件
save_file = file_path & \”合并表.xlsx\”
ws.Parent.SaveAs filename:=save_file
ws.Parent.Close (False)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

举例

合并《Excel·VBA按列拆分工作表》，sub2拆分后的工作表

合并参数：title_row = 0，end_row = 0

3.1，合并且显示原工作簿名称、原工作表名称

应评论建议，增加在A列显示原工作簿名称，B列显示原工作表名称

Sub 合并文件夹下所有工作簿中所有工作表1()
\’文件夹下所有工作簿wb所有工作表ws合并保存至新建工作表（但不含子文件夹），但不修改原数据（工作表格式相同）
Dim wb, ws, title_row, end_row, copy_title, file_path, file_name, save_file, fso As Object
\’——————–参数填写：title_row，数字，第1行为1向下递增；end_row，数字；file_path，合并文件夹
title_row = 1 \’表头行数，仅复制1次；如果为0，则表示没有表头或表头每次都复制
end_row = 0 \’表尾行数，不参与合并
file_path = \”E:\\测试\\拆分表\\\” \’待合并工作簿所在的文件夹
file_name = Dir(file_path & \”*.xlsx\”)
If title_row > 0 Then copy_title = True Else copy_title = False \’是否复制表头
If title_row < 0 Then Debug.Print \”title_row参数错误，必须为>=0的整数\”: Exit Sub
Application.ScreenUpdating = False \’关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False \’不显示警告信息
Set fso = CreateObject(\”Scripting.FileSystemObject\”)
Workbooks.Add \’新建工作表
Set ws = ActiveSheet: ws.Name = \”合并表\”: ws.Cells(1, \”a\”).Resize(1, 2) = Array(\”原工作簿名称\”, \”原工作表名称\”)
Do While file_name <> \”\”
Set wb = Workbooks.Open(file_path & file_name)
For Each sht In wb.Worksheets
If copy_title = True Then \’复制表头，仅执行1次
sheet_col = sht.UsedRange.Columns.count
sht.Range(Cells(1, \”a\”), Cells(title_row, sheet_col)).Copy ws.Cells(1, \”c\”)
copy_title = False
End If
If WorksheetFunction.CountA(ws.Rows(1)) = 0 Then ws.Rows(1).Delete
write_row = ws.UsedRange.Rows.count + 1 \’合并工作表的第一个空行写入
sheet_row = sht.UsedRange.Rows.count: sheet_col = sht.UsedRange.Columns.count
sht.Range(Cells(title_row + 1, \”a\”), Cells(sheet_row – end_row, sheet_col)).Copy ws.Cells(write_row, \”c\”)
ws.Cells(write_row, \”a\”).Resize(sheet_row – title_row – end_row, 2) = Array(fso.GetBaseName(file_name), sht.Name)
Next
wb.Close (False)
file_name = Dir \’下一个文件名
Loop
\’保存文件
save_file = file_path & \”合并表.xlsx\”
ws.Parent.SaveAs filename:=save_file
ws.Parent.Close (False)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

4，合并文件夹下所有工作簿中同名工作表

对工作簿按工作表名称进行合并，汇总所有同名工作表，保存为单独工作簿

Sub 合并文件夹下所有工作簿中同名工作表()
\’文件夹下所有工作簿wb所有工作表ws按名称合并保存至新建工作表（但不含子文件夹），但不修改原数据（工作表格式相同）
Dim dict As Object, sht As Worksheet, file_path$, file_name$, title_row, end_row, save_file$
\’——————–参数填写：title_row，数字，第1行为1向下递增；end_row，数字；file_path，合并文件夹
title_row = 1 \’表头行数，不参与合并
end_row = 0 \’表尾行数，不参与合并
file_path = \”E:\\测试\\拆分表\\\” \’待合并工作簿所在的文件夹
file_name = Dir(file_path & \”*.xlsx\”)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set dict = CreateObject(\”scripting.dictionary\”)
Set write_wb = Workbooks.Add \’新建工作簿，合并文件
\’新建工作簿默认工作表，防止有同名被合并表，导致整表复制后名称改变；但会缺少表头
For Each sht In write_wb.Worksheets
dict(sht.Name) = \”\”
Next
Do While file_name <> \”\”
Set wb = Workbooks.Open(file_path & file_name)
For Each sht In wb.Worksheets
If Not dict.Exists(sht.Name) Then \’不存在的，直接复制整表
dict(sht.Name) = \”\”
sht.Copy After:=write_wb.Sheets(write_wb.Sheets.count)
Else
Set write_ws = write_wb.Worksheets(sht.Name)
\’首行为空，会导致后续数据被覆盖
If WorksheetFunction.CountA(write_ws.Rows(1)) = 0 Then write_ws.Rows(1).Delete
write_row = write_ws.UsedRange.Rows.count + 1 \’合并工作表的第一个空行写入
sheet_row = sht.UsedRange.Rows.count
sht.Rows(title_row + 1 & \”:\” & sheet_row – end_row).Copy write_ws.Range(\”A\” & write_row)
End If
\’Exit Do
Next
wb.Close (False)
file_name = Dir \’下一个文件名
Loop
\’保存文件
save_file = file_path & \”合并表.xlsx\”
write_wb.SaveAs filename:=save_file
write_wb.Close (False)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

4.1，合并且显示原工作簿名称

应评论建议，增加在A列显示原工作簿名称；因按同名工作表合并，故没有显示原工作表名称的必要

Sub 合并文件夹下所有工作簿中同名工作表1()
\’文件夹下所有工作簿wb所有工作表ws按名称合并保存至新建工作表（但不含子文件夹），但不修改原数据（工作表格式相同）
Dim dict As Object, sht As Worksheet, fso As Object
Dim file_path$, file_name$, title_row, end_row, save_file$
\’——————–参数填写：title_row，数字，第1行为1向下递增；end_row，数字；file_path，合并文件夹
title_row = 1 \’表头行数，不参与合并
end_row = 0 \’表尾行数，不参与合并
file_path = \”E:\\测试\\拆分表\\\” \’待合并工作簿所在的文件夹
file_name = Dir(file_path & \”*.xlsx\”)
Application.ScreenUpdating = False \’关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False \’不显示警告信息
Set fso = CreateObject(\”Scripting.FileSystemObject\”)
Set dict = CreateObject(\”scripting.dictionary\”)
Set write_wb = Workbooks.Add \’新建工作簿，合并文件
\’新建工作簿默认工作表，防止有同名被合并表，导致整表复制后名称改变；但会缺少表头
For Each sht In write_wb.Worksheets
dict(sht.Name) = \”\”: [a1] = \”原工作簿名称\”
Next
Do While file_name <> \”\”
Set wb = Workbooks.Open(file_path & file_name)
For Each sht In wb.Worksheets
If Not dict.Exists(sht.Name) Then \’不存在的，直接复制整表
dict(sht.Name) = \”\”
sht.Copy After:=write_wb.Sheets(write_wb.Sheets.count)
ActiveSheet.Columns(1).Insert: [a1] = \”原工作簿名称\” \’插入列
Range(\”a2:a\” & ActiveSheet.UsedRange.Rows.count).Value = fso.GetBaseName(file_name) \’需要扩展名可直接赋值file_name
Else
Set write_ws = write_wb.Worksheets(sht.Name)
If WorksheetFunction.CountA(write_ws.Rows(1)) = 0 Then write_ws.Rows(1).Delete
write_row = write_ws.UsedRange.Rows.count + 1 \’合并工作表的第一个空行写入
sheet_row = sht.UsedRange.Rows.count: sheet_col = sht.UsedRange.Columns.count
sht.Range(Cells(title_row + 1, \”a\”), Cells(sheet_row – end_row, sheet_col)).Copy write_ws.Range(\”B\” & write_row)
write_ws.Cells(write_row, \”a\”).Resize(sheet_row – title_row – end_row) = fso.GetBaseName(file_name)
End If
Next
wb.Close (False)
file_name = Dir \’下一个文件名
Loop
\’保存文件
save_file = file_path & \”合并表.xlsx\”
write_wb.SaveAs filename:=save_file
write_wb.Close (False)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub