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, 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
'保存文件
ws.Parent.SaveAs filename:=file_path & "合并表.xlsx"
ws.Parent.Close (False)
Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub
举例
合并《Excel·VBA按列拆分工作表》，sub2拆分后的工作表
合并参数：title_row = 0，end_row = 0
3.1，合并且显示原工作簿名称、原工作表名称
2022.8.27更新，应评论建议
增加在A列显示原工作簿名称，B列显示原工作表名称
Sub 合并文件夹下所有工作簿中所有工作表1()
'文件夹下所有工作簿wb所有工作表ws合并保存至新建工作表（但不含子文件夹），但不修改原数据（工作表格式相同）
Dim write_ws As Worksheet, wb As Workbook, sht As Worksheet, fso As Object
Dim title_row&, end_row&, write_row&, sht_row&, sht_col&, copy_row&, file_path$, file_name$
'--------------------参数填写：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 Debug.Print "title_row参数错误，必须为>=0的整数": Exit Sub
Application.ScreenUpdating = False '关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False '不显示警告信息
Set fso = CreateObject("Scripting.FileSystemObject")
Do While file_name <> ""
Set wb = Workbooks.Open(file_path & file_name)
For Each sht In wb.Worksheets
If WorksheetFunction.CountA(sht.UsedRange.Cells) <> 0 Then '非空工作表
If write_ws Is Nothing Then
sht.Copy: Set write_ws = ActiveSheet '整体复制工作表
write_ws.Name = "合并表": write_ws.Columns("a:b").Insert '插入列
write_ws.[a1].Resize(1, 2) = Array("原工作簿名称", "原工作表名称")
write_row = write_ws.UsedRange.Rows.Count
write_ws.[a2].Resize(write_row - title_row, 2) = Array(fso.GetBaseName(file_name), sht.Name)
If end_row > 0 Then '删除表尾行
write_ws.Cells(write_row, 1).Offset(-end_row + 1, 0).Resize(end_row, 1).EntireRow.Delete
End If
Else
write_row = write_ws.UsedRange.Rows.Count + 1 '合并工作表的第一个空行写入
sht_row = sht.UsedRange.Rows.Count: sht_col = sht.UsedRange.Columns.Count
copy_row = sht_row - title_row - end_row '复制行数
sht.Cells(title_row + 1, "a").Resize(copy_row, sht_col).Copy write_ws.Cells(write_row, "c")
write_ws.Cells(write_row, "a").Resize(copy_row, 2) = Array(fso.GetBaseName(file_name), sht.Name)
End If
End If
Next
wb.Close (False) '关闭工作簿
file_name = Dir '下一个文件名
Loop
'保存文件
write_ws.Parent.SaveAs filename:=file_path & "合并表.xlsx"
write_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，合并且显示原工作簿名称
2022.8.27更新，应评论建议
增加在A列显示原工作簿名称；因按同名工作表合并，故没有显示原工作表名称的必要
2023.5.23更新，应评论建议
为避免工作表公式因复制粘贴导致引用错误，新增粘贴为数值功能，且不改变工作表格式
Sub 合并文件夹下所有工作簿中同名工作表1()
'文件夹下所有工作簿wb所有工作表ws按名称合并保存至新建工作表（但不含子文件夹），但不修改原数据（工作表格式相同）
Dim dict As Object, sht As Worksheet, fso As Object, only_value As Boolean
Dim file_path$, file_name$, title_row&, end_row&, save_file$
Dim write_row&, sht_row&, sht_col&, copy_row&, temp, r&
'--------------------参数填写：title_row，数字，第1行为1向下递增；end_row，数字
title_row = 1: end_row = 0 '表头、表尾行数，不参与合并
only_value = True '仅粘贴为数值，是/否
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) = "": sht.[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) = "": temp = sht.UsedRange.Value
sht.Copy After:=write_wb.Sheets(write_wb.Sheets.Count)
With ActiveSheet
.Columns(1).Insert: [a1] = "原工作簿名称" '插入列
If end_row > 0 Then '删除表尾行
r = .UsedRange.Rows.Count
.Cells(r, 1).Offset(-end_row + 1, 0).Resize(end_row, 1).EntireRow.Delete
End If
.Cells(title_row + 1, 1).Resize(.UsedRange.Rows.Count - title_row, 1) = fso.GetBaseName(file_name) '需要扩展名可直接赋值file_name
If only_value Then .[b1].Resize(UBound(temp) - end_row, UBound(temp, 2)) = temp
End With
Else
With write_wb.Worksheets(sht.Name)
If WorksheetFunction.CountA(.Rows(1)) = 0 Then .Rows(1).Delete
write_row = .UsedRange.Rows.Count + 1 '合并工作表的第一个空行写入
sht_row = sht.UsedRange.Rows.Count: sht_col = sht.UsedRange.Columns.Count
copy_row = sht_row - title_row - end_row '复制行数
temp = sht.Cells(title_row + 1, "a").Resize(copy_row, sht_col).Value
sht.Cells(title_row + 1, "a").Resize(copy_row, sht_col).Copy .Cells(write_row, "b")
If only_value Then .Cells(write_row, "b").Resize(copy_row, sht_col) = temp
.Cells(write_row, "a").Resize(copy_row) = fso.GetBaseName(file_name)
End With
End If
Next
wb.Close (False) '关闭工作簿
file_name = Dir '下一个文件名
Loop
For Each sht In write_wb.Worksheets '删除空表ws
If sht.UsedRange.Rows.Count = 1 Then sht.Delete
Next
'保存文件
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按列拆分工作表、工作簿》，sub3（工作簿按列拆分）拆分后的工作簿
合并参数：title_row = 1，end_row = 0，合并后
5，合并文件夹下所有工作簿中所有工作表，横向汇总数据
对格式相同的工作表进行合并，横向汇总数据（注意：如果数据量较大，需要修改arr数组的Resize大小）
Sub 合并文件夹下所有工作簿中所有工作表_横向汇总数据()
'多列键汇总单列数据，适用工作表格式相同、待汇总数据为最后一列
Dim dict As Object, sht As Worksheet, title_col&, key_col, s_row&
Dim file_path$, file_name$, arr, brr, temp$, w_row&, w_col&, i&, j&, r&
'--------------------参数填写：title_col、key_col、s_row，大于0的整数
title_col = 3 '表头列数，每个拆分后的sheet都保留，数值
key_col = Array(2, 3) '关键值列，按该列的值相同的进行合并，数值数组
s_row = 2 '数据遍历开始行号
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 '新建工作簿，合并文件
Set write_ws = ActiveSheet: write_ws.Name = "合并表"
Do While file_name <> ""
Set wb = Workbooks.Open(file_path & file_name)
For Each sht In wb.Worksheets
With sht
If WorksheetFunction.CountA(.UsedRange.Cells) <> 0 Then '非空工作表
If w_col = 0 Then
arr = .[a1].CurrentRegion.Resize(10 ^ 3, 10 ^ 2) 'arr最大化，写入行列号初始化
w_row = .[a1].CurrentRegion.Rows.Count: w_col = .[a1].CurrentRegion.Columns.Count
For i = s_row To w_row
temp = ""
For Each k In key_col
temp = temp & "-" & arr(i, k)
Next
temp = Mid(temp, 2): dict(temp) = i '键去除开头的"-"，值为行号
Next
Else
brr = .[a1].CurrentRegion
w_col = w_col + 1: arr(1, w_col) = brr(1, UBound(brr, 2)) '新增列号
For i = s_row To UBound(brr)
temp = ""
For Each k In key_col
temp = temp & "-" & brr(i, k)
Next
temp = Mid(temp, 2)
If Not dict.exists(temp) Then '新增关键值
w_row = w_row + 1: dict(temp) = w_row '新增行号
For j = 1 To UBound(brr, 2) - 1
arr(w_row, j) = brr(i, j)
Next
End If
r = dict(temp): arr(r, w_col) = brr(i, UBound(brr, 2)) '写入数据
Next
End If
End If
End With
Next
wb.Close (False)
file_name = Dir '下一个文件名
Loop
write_ws.[a1].Resize(w_row, w_col) = arr
write_wb.SaveAs filename:=file_path & "合并表.xlsx"
write_wb.Close (False)
Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub
举例
对文件夹下多个工作簿、每个工作簿下有多个工作表、每个工作表格式相同，横向汇总某一列数据。且不同工作簿可能存在行数不同的情况，按字典键值汇总，但不进行计算，结果如下：
6，合并子文件夹所有工作簿中所有工作表，纵向汇总数据
适用所有工作簿中的所有工作表格式都相同的合并，每个子文件夹生成一个工作表，工作表中包含该子文件夹所有工作簿数据，子文件夹名命名该工作表
不仅可以在A列显示 “原工作簿名称” 、B列显示 “原工作表名称” 信息，同时参数old_name = False也可将该信息删除
新增可指定合并至指定文件的功能，而文章之前内容只能合并至固定新建文件。其优势在于： 遍历子文件夹获取的子文件夹名顺序，及其自动生成的工作表名称顺序，不一定是自己想要的/实际看到的，如果事先自建合并文件，可自行修改工作表名称、顺序，然后运行代码，最终生成的文件内工作表顺序就是自己想要的
Sub 合并文件夹下子文件夹所有工作簿中所有工作表_纵向汇总数据()
'最终合并文件sheet以子文件夹命名，适用工作表格式相同
'合并文件A列显示原工作簿名称，B列显示原工作表名称；新增可指定合并文件
Dim dict As Object, sht As Worksheet, fso As Object, only_value As Boolean, old_name As Boolean
Dim file_path$, file_name$, title_row&, end_row&, save_file$, s$, title_name, wb As Workbook
Dim write_row&, sht_row&, sht_col&, copy_row&, nrr, p, f, temp, r&, write_wb As Workbook
'--------------------参数填写：title_row，数字，第1行为1向下递增；end_row，数字
title_row = 1: end_row = 0 '表头、表尾行数，不参与合并
'file_path待合并的子文件夹所在文件夹；file_name合并至指定文件，为空""或注释则自动生成文件
file_path = "E:\测试\拆分表\"
'file_name = "E:\测试\拆分表\指定合并表.xlsx"
only_value = True '仅粘贴为数值，是/否
old_name = True '写入原工作簿、工作表名称，是/否
Application.ScreenUpdating = False '关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False '不显示警告信息
Set dict = CreateObject("scripting.dictionary"): delimiter = Chr(28)
Set fso = CreateObject("Scripting.FileSystemObject"): tm = Timer
If Len(file_name) Then 'file_name不为空则打开，为空则新建工作簿，即合并文件
Set write_wb = Workbooks.Open(file_name)
Else
Set write_wb = Workbooks.Add
End If
'新建工作簿默认工作表，防止有同名被合并表，导致整表复制后名称改变；并清空表格
title_name = Array("原工作簿名称", "原工作表名称")
For Each sht In write_wb.Worksheets
dict(sht.Name) = "": sht.UsedRange.Delete: sht.[a1].Resize(1, 2) = title_name
Next
For Each f In fso.GetFolder(file_path).SubFolders '获取所有子文件夹名
s = s & delimiter & f.Name
Next
fd = Split(Mid(s, 2), delimiter)
For Each p In fd
For Each f In fso.GetFolder(file_path & p).Files '空文件夹不影响
If f.Name Like "*.xls*" Then
Set wb = Workbooks.Open(f)
For Each sht In wb.Worksheets
If Not dict.Exists(p) Then '子文件夹不存在的，直接复制整表
dict(p) = ""
sht.Copy After:=write_wb.Sheets(write_wb.Sheets.Count)
ActiveSheet.Name = p
With write_wb.Worksheets(p)
nrr = Array(fso.GetBaseName(f.Name), sht.Name): temp = sht.UsedRange.Value
.Columns("a:b").Insert: .[a1].Resize(1, 2) = title_name '插入列
If end_row > 0 Then '删除表尾行
r = .UsedRange.Rows.Count
.Cells(r, 1).Offset(-end_row + 1, 0).Resize(end_row, 1).EntireRow.Delete
End If
.Cells(title_row + 1, 1).Resize(.UsedRange.Rows.Count - title_row, 2) = nrr
If only_value Then .[c1].Resize(UBound(temp) - end_row, UBound(temp, 2)) = temp
End With
Else
With write_wb.Worksheets(p)
nrr = Array(fso.GetBaseName(f.Name), sht.Name) '需要扩展名可直接赋值f.Name
If .UsedRange.Rows.Count = 1 Then '空表为1
temp = sht.UsedRange.Value: sht.UsedRange.Copy .[c1] '含格式复制
If end_row > 0 Then '删除表尾行
r = .UsedRange.Rows.Count
.Cells(r, 1).Offset(-end_row + 1, 0).Resize(end_row, 1).EntireRow.Delete
End If
.Cells(title_row + 1, 1).Resize(.UsedRange.Rows.Count - title_row, 2) = nrr
If only_value Then .[c1].Resize(UBound(temp) - end_row, UBound(temp, 2)) = temp
Else
write_row = .UsedRange.Rows.Count + 1 '合并工作表的第一个空行写入
sht_row = sht.UsedRange.Rows.Count: sht_col = sht.UsedRange.Columns.Count
copy_row = sht_row - title_row - end_row '复制行数
temp = sht.Cells(title_row + 1, "a").Resize(copy_row, sht_col).Value
sht.Cells(title_row + 1, "a").Resize(copy_row, sht_col).Copy .Cells(write_row, "c")
If only_value Then .Cells(write_row, "c").Resize(copy_row, sht_col) = temp
.Cells(write_row, 1).Resize(copy_row, 2) = nrr
End If
End With
End If
Next
wb.Close (False)
End If
Next
Next
For Each sht In write_wb.Worksheets '删除空表ws
If sht.UsedRange.Rows.Count = 1 Then sht.Delete
Next
If Not old_name Then '无需写入原工作簿、工作表名称
For Each sht In write_wb.Worksheets
sht.Columns("a:b").Delete
Next
End If
If Len(file_name) Then '保存文件，file_name不为空
write_wb.Close (True)
Else
save_file = file_path & "合并表.xlsx"
write_wb.SaveAs filename:=save_file
write_wb.Close (False)
End If
Application.ScreenUpdating = True: Application.DisplayAlerts = True
Debug.Print "文件夹合并完成，用时：" & Format(Timer - tm, "0.00")
End Sub
举例
合并4.1-举例中同样的数据，但是每个文件都放入一个同名文件夹中
合并参数：title_row = 1，end_row = 0，file_name被注释，合并后
指定合并表，并自行修改工作表名称、顺序
合并参数：file_path不变，file_name为指定合并表的文件路径，合并后
7，合并子文件夹同名工作簿中同名工作表，纵向汇总数据
针对解决本问题：《Excel吧-批量合并同名工作簿》
合并不同文件夹中的同名工作簿，并按工作表名称纵向合并数据。适用同名工作簿中的同名工作表格式相同的合并，按每个工作簿名称生成一个合并工作簿，包含所有子文件夹中所有同名工作簿数据；合并工作簿统一保存在“合并表”文件夹
7.1，实现方法1
采用按子文件夹顺序，依次遍历子文件夹中所有工作簿，因此合并工作簿需要反复打开写入再保存关闭，速度较慢
Sub 合并子文件夹同名工作簿中同名工作表_纵向汇总数据1()
'最终合并文件sheet以工作簿名命名，适用工作表格式相同；合并文件A列显示原子文件夹名
Dim dict As Object, sht As Worksheet, fso As Object, only_value As Boolean, old_name As Boolean
Dim file_path$, save_path$, title_row&, end_row&, save_file$, s$, wb As Workbook
Dim write_row&, sht_row&, sht_col&, copy_row&, p, f, temp, r&, write_wb As Workbook
'--------------------参数填写：title_row，数字，第1行为1向下递增；end_row，数字
title_row = 1: end_row = 0 '表头、表尾行数，不参与合并
file_path = "E:\测试\拆分表\合并工作簿7\" 'file_path待合并的子文件夹所在文件夹
save_path = file_path + "合并表\" '合并后的表格保存路径
only_value = True '仅粘贴为数值，是/否
old_name = True '写入原子文件夹名，是/否
Application.ScreenUpdating = False '关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False '不显示警告信息
Set dict = CreateObject("scripting.dictionary"): delimiter = Chr(28)
Set fso = CreateObject("Scripting.FileSystemObject"): tm = Timer
If fso.FolderExists(save_path) Then Debug.Print "保存文件夹已存在，会导致错误，请删除": Exit Sub
For Each f In fso.GetFolder(file_path).SubFolders '获取所有子文件夹名
s = s & delimiter & f.Name
Next
fd = Split(Mid(s, 2), delimiter)
If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path) '创建文件夹
For Each p In fd
For Each f In fso.GetFolder(file_path & p).Files '空文件夹不影响
If f.Name Like "*.xls*" Then
Set wb = Workbooks.Open(f)
s = fso.GetBaseName(f.Name) '工作簿文件名，不带扩展名
If Not dict.Exists(s) Then '工作簿不存在的，直接复制整个工作簿
Set dict(s) = CreateObject("scripting.dictionary")
wb.Worksheets.Copy
For Each sht In ActiveWorkbook.Worksheets
dict(s)(sht.Name) = "": temp = sht.UsedRange.Value
sht.Columns("a:a").Insert: sht.[a1] = "子文件夹" '插入列
If end_row > 0 Then '删除表尾行
r = sht.UsedRange.Rows.Count
sht.Cells(r, 1).Offset(-end_row + 1, 0).Resize(end_row, 1).EntireRow.Delete
End If
sht.Cells(title_row + 1, 1).Resize(sht.UsedRange.Rows.Count - title_row, 1) = p
If only_value Then sht.[b1].Resize(UBound(temp) - end_row, UBound(temp, 2)) = temp
Next
wb.Close (False)
save_file = save_path & s & "_合并表.xlsx" '保存文件，无发打开2个同名文件，故加标识
ActiveWorkbook.SaveAs filename:=save_file
ActiveWorkbook.Close (False)
Else
Set write_wb = Workbooks.Open(save_path & s & "_合并表.xlsx")
For Each sht In wb.Worksheets
If Not dict(s).Exists(sht.Name) Then '工作表不存在，直接复制
sht.Copy After:=write_wb.Sheets(write_wb.Sheets.Count)
dict(s)(sht.Name) = "": temp = sht.UsedRange.Value
With write_wb.Worksheets(sht.Name)
.Columns("a:a").Insert: .[a1] = "子文件夹" '插入列
If end_row > 0 Then '删除表尾行
r = .UsedRange.Rows.Count
.Cells(r, 1).Offset(-end_row + 1, 0).Resize(end_row, 1).EntireRow.Delete
End If
.Cells(title_row + 1, 1).Resize(.UsedRange.Rows.Count - title_row, 1) = p
If only_value Then .[b1].Resize(UBound(temp) - end_row, UBound(temp, 2)) = temp
End With
Else
With write_wb.Worksheets(sht.Name)
write_row = .UsedRange.Rows.Count + 1 '合并工作表的第一个空行写入
sht_row = sht.UsedRange.Rows.Count: sht_col = sht.UsedRange.Columns.Count
copy_row = sht_row - title_row - end_row '复制行数
temp = sht.Cells(title_row + 1, "a").Resize(copy_row, sht_col).Value
sht.Cells(title_row + 1, "a").Resize(copy_row, sht_col).Copy .Cells(write_row, "b")
If only_value Then .Cells(write_row, "b").Resize(copy_row, sht_col) = temp
.Cells(write_row, 1).Resize(copy_row, 1) = p
End With
End If
Next
wb.Close (False)
write_wb.Close (True) '保存并关闭
End If
End If
Next
Next
If Not old_name Then '无需写入原子文件夹名
For Each f In fso.GetFolder(save_path).Files
Set write_wb = Workbooks.Open(f)
For Each sht In write_wb.Worksheets
sht.Columns("a:a").Delete
Next
write_wb.Close (True)
Next
End If
For Each f In fso.GetFolder(save_path).Files
f.Name = Replace(f.Name, "_合并表", "") '合并文件名删除标识
Next
Application.ScreenUpdating = True: Application.DisplayAlerts = True
Debug.Print "文件夹合并完成，用时：" & Format(Timer - tm, "0.00")
End Sub
7.2，实现方法2
采用每次遍历1个工作簿时，如果是之前从未遍历过的工作簿名称时，直接循环遍历其他子文件夹中的同名工作簿；同时，按子文件夹顺序，依次遍历子文件夹中所有工作簿，确保所有工作簿都被遍历。因为减少了合并工作簿反复打开、保存、关闭的操作，所以速度较实现方法1稍快
Sub 合并子文件夹同名工作簿中同名工作表_纵向汇总数据2()
'最终合并文件sheet以工作簿名命名，适用工作表格式相同；合并文件A列显示原子文件夹名
Dim dict As Object, sht As Worksheet, fso As Object, only_value As Boolean, old_name As Boolean
Dim file_path$, save_path$, title_row&, end_row&, save_file$, s$, wb As Workbook
Dim write_row&, sht_row&, sht_col&, copy_row&, p, f, temp, r&, pp, ff
'--------------------参数填写：title_row，数字，第1行为1向下递增；end_row，数字
title_row = 1: end_row = 0 '表头、表尾行数，不参与合并
file_path = "E:\测试\拆分表\合并工作簿7\" 'file_path待合并的子文件夹所在文件夹
save_path = file_path + "合并表\" '合并后的表格保存路径
only_value = True '仅粘贴为数值，是/否
old_name = True '写入原子文件夹名，是/否
Application.ScreenUpdating = False '关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False '不显示警告信息
Dim pn_dict As Object: Set pn_dict = CreateObject("scripting.dictionary") '记录已遍历文件名
Set dict = CreateObject("scripting.dictionary"): delimiter = Chr(28)
Set fso = CreateObject("Scripting.FileSystemObject"): tm = Timer
If fso.FolderExists(save_path) Then Debug.Print "保存文件夹已存在，会导致错误，请删除": Exit Sub
For Each f In fso.GetFolder(file_path).SubFolders '获取所有子文件夹名
s = s & delimiter & f.Name
Next
fd = Split(Mid(s, 2), delimiter)
If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path) '创建文件夹
For Each p In fd
For Each f In fso.GetFolder(file_path & p).Files '空文件夹不影响
If f.Name Like "*.xls*" Then
pn = p & "\" & f.Name: s = fso.GetBaseName(f.Name) 's工作簿文件名，不带扩展名
If Not pn_dict.Exists(pn) Then '未遍历
Set wb = Workbooks.Open(f): pn_dict(pn) = ""
Set dict(s) = CreateObject("scripting.dictionary")
wb.Worksheets.Copy '工作簿不存在的，直接复制整个工作簿
With ActiveWorkbook '复制后的工作簿，合并表
For Each sht In .Worksheets
dict(s)(sht.Name) = "": temp = sht.UsedRange.Value
sht.Columns("a:a").Insert: sht.[a1] = "子文件夹" '插入列
If end_row > 0 Then '删除表尾行
r = sht.UsedRange.Rows.Count
sht.Cells(r, 1).Offset(-end_row + 1, 0).Resize(end_row, 1).EntireRow.Delete
End If
sht.Cells(title_row + 1, 1).Resize(sht.UsedRange.Rows.Count - title_row, 1) = p
If only_value Then sht.[b1].Resize(UBound(temp) - end_row, UBound(temp, 2)) = temp
Next
wb.Close (False)
For Each pp In fd '遍历所有子文件夹同名工作簿
For Each ff In fso.GetFolder(file_path & pp).Files
If ff.Name Like s & ".xls*" Then
pn = pp & "\" & ff.Name
If Not pn_dict.Exists(pn) Then '未遍历
Set wb = Workbooks.Open(ff): pn_dict(pn) = ""
For Each sht In wb.Worksheets
If Not dict(s).Exists(sht.Name) Then '工作表不存在，直接复制
sht.Copy After:=.Sheets(.Sheets.Count)
dict(s)(sht.Name) = "": temp = sht.UsedRange.Value
With .Worksheets(sht.Name)
.Columns("a:a").Insert: .[a1] = "子文件夹" '插入列
If end_row > 0 Then '删除表尾行
r = .UsedRange.Rows.Count
.Cells(r, 1).Offset(-end_row + 1, 0).Resize(end_row, 1).EntireRow.Delete
End If
.Cells(title_row + 1, 1).Resize(.UsedRange.Rows.Count - title_row, 1) = pp
If only_value Then .[b1].Resize(UBound(temp) - end_row, UBound(temp, 2)) = temp
End With
Else
With .Worksheets(sht.Name)
write_row = .UsedRange.Rows.Count + 1 '合并工作表的第一个空行写入
sht_row = sht.UsedRange.Rows.Count: sht_col = sht.UsedRange.Columns.Count
copy_row = sht_row - title_row - end_row '复制行数
temp = sht.Cells(title_row + 1, "a").Resize(copy_row, sht_col).Value
sht.Cells(title_row + 1, "a").Resize(copy_row, sht_col).Copy .Cells(write_row, "b")
If only_value Then .Cells(write_row, "b").Resize(copy_row, sht_col) = temp
.Cells(write_row, 1).Resize(copy_row, 1) = pp
End With
End If
Next
wb.Close (False)
End If
End If
Next
Next
If Not old_name Then '无需写入原子文件夹名
For Each sht In .Worksheets
sht.Columns("a:a").Delete
Next
End If
.SaveAs filename:=save_path & s & ".xlsx"
.Close (False)
End With
End If
End If
Next
Next
Application.ScreenUpdating = True: Application.DisplayAlerts = True
Debug.Print "文件夹合并完成，用时：" & Format(Timer - tm, "0.00")
End Sub
举例，2种实现方法对比
合并4.1-举例中同样的数据，但是所有5个工作簿都放入12个文件夹中，文件夹依次命名为“1月-12月”
需要合并的数据共有，60个工作簿180个工作表
合并参数：title_row = 1，end_row = 0，合并后
2种实现方法代码运行速度对比： 60个工作簿180个工作表
方法1多次运行，用时在40-60秒之间
方法2多次运行，用时在22.5-29秒之间
2种实现方法生成的合并工作簿结果完全一致，但方法2速度更快。在代码行数差不多的情况下，不同的遍历方式对运行速度的影响较大