Excel·VBA合并工作簿

1，合并文件夹下所有工作簿
- 1.1，合并且建立超链接目录
- - 举例
2，合并工作簿中所有工作表
- 2.1，纵向合并
- - 举例
- 2.2，横向合并
- - 举例
3，合并文件夹下所有工作簿中所有工作表
- 举例
- 3.1，合并且显示原工作簿名称、原工作表名称
4，合并文件夹下所有工作簿中同名工作表
- 4.1，合并且显示原工作簿名称

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.Worksheetssht.Copy After:=write_wb.Sheets(write_wb.Sheets.Count)Nextwb.Close (False)file_name = Dir  '下一个文件名Loop'保存文件save_file = file_path & "合并表.xlsx"write_wb.SaveAs filename:=save_filewrite_wb.Close (False)Application.ScreenUpdating = TrueApplication.DisplayAlerts = True
End Sub

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

Sub 合并文件夹下所有工作簿并建立目录()'文件夹下所有工作簿wb所有工作表ws合并为一个新工作簿（但不含子文件夹），不修改数据，并建立目录超链接Dim write_wb As Workbook, wb As Workbook, list_ws As Worksheet, sht As WorksheetDim 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 = 1Set fso = CreateObject("Scripting.FileSystemObject")Do While file_name <> ""Set wb = Workbooks.Open(file_path & file_name)For Each sht In wb.Worksheetssht.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).Namelist_ws.Hyperlinks.Add anchor:=list_ws.Cells(w, 2), Address:="", SubAddress:="'" & newname & "'!a1", TextToDisplay:=newnameNextwb.Close (False)file_name = Dir  '下一个文件名Loop'保存文件list_ws.Columns(1).AutoFit  '列宽自适应save_file = file_path & "合并表.xlsx"write_wb.SaveAs filename:=save_filewrite_wb.Close (False)Application.ScreenUpdating = TrueApplication.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 SubApplication.ScreenUpdating = False  '关闭屏幕更新，加快程序运行Application.DisplayAlerts = False   '不显示警告信息'遍历，复制表体For i = 1 To Worksheets.count:If Worksheets(i).Name <> ws.Name ThenIf copy_title = True Then  '复制表头，仅执行1次Worksheets(i).Rows(1 & ":" & title_row).Copy ws.Range("A1")copy_title = FalseEnd If'首行为空，会导致后续数据被覆盖If WorksheetFunction.CountA(ws.Rows(1)) = 0 Then ws.Rows(1).Deletewrite_row = ws.UsedRange.Rows.count + 1  '合并工作表的第一个空行写入sheet_row = Worksheets(i).UsedRange.Rows.countWorksheets(i).Rows(title_row + 1 & ":" & sheet_row - end_row).Copy ws.Range("A" & write_row)End IfNextApplication.ScreenUpdating = TrueApplication.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 ActiveWorkbookSet ws = .Worksheets.Add(before:=Sheets(1))  '最前添加新sheet，即为合并工作表ws.Name = "合并表"For Each sht In .WorksheetsIf sht.Name <> ws.Name Then'首列为空时，会导致后续数据被覆盖If WorksheetFunction.CountA(ws.Columns(1)) = 0 Then ws.Columns(1).Deletewrite_col = ws.UsedRange.Columns.Count + 1sht.UsedRange.Copy ws.Cells(1, write_col)End IfNextEnd WithApplication.ScreenUpdating = TrueApplication.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 SubApplication.ScreenUpdating = False  '关闭屏幕更新，加快程序运行Application.DisplayAlerts = False   '不显示警告信息Workbooks.Add    '新建工作表Set ws = ActiveSheetws.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 = FalseEnd If'首行为空，会导致后续数据被覆盖If WorksheetFunction.CountA(ws.Rows(1)) = 0 Then ws.Rows(1).Deletewrite_row = ws.UsedRange.Rows.count + 1  '合并工作表的第一个空行写入sheet_row = wb.Worksheets(i).UsedRange.Rows.countwb.Worksheets(i).Rows(title_row + 1 & ":" & sheet_row - end_row).Copy ws.Range("A" & write_row)Nextwb.Close (False)file_name = Dir  '下一个文件名Loop'保存文件save_file = file_path & "合并表.xlsx"ws.Parent.SaveAs filename:=save_filews.Parent.Close (False)Application.ScreenUpdating = TrueApplication.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 SubApplication.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.WorksheetsIf copy_title = True Then  '复制表头，仅执行1次sheet_col = sht.UsedRange.Columns.countsht.Range(Cells(1, "a"), Cells(title_row, sheet_col)).Copy ws.Cells(1, "c")copy_title = FalseEnd IfIf WorksheetFunction.CountA(ws.Rows(1)) = 0 Then ws.Rows(1).Deletewrite_row = ws.UsedRange.Rows.count + 1  '合并工作表的第一个空行写入sheet_row = sht.UsedRange.Rows.count: sheet_col = sht.UsedRange.Columns.countsht.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)Nextwb.Close (False)file_name = Dir  '下一个文件名Loop'保存文件save_file = file_path & "合并表.xlsx"ws.Parent.SaveAs filename:=save_filews.Parent.Close (False)Application.ScreenUpdating = TrueApplication.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 = FalseApplication.DisplayAlerts = FalseSet dict = CreateObject("scripting.dictionary")Set write_wb = Workbooks.Add    '新建工作簿，合并文件'新建工作簿默认工作表，防止有同名被合并表，导致整表复制后名称改变；但会缺少表头For Each sht In write_wb.Worksheetsdict(sht.Name) = ""NextDo While file_name <> ""Set wb = Workbooks.Open(file_path & file_name)For Each sht In wb.WorksheetsIf Not dict.Exists(sht.Name) Then  '不存在的，直接复制整表dict(sht.Name) = ""sht.Copy After:=write_wb.Sheets(write_wb.Sheets.count)ElseSet write_ws = write_wb.Worksheets(sht.Name)'首行为空，会导致后续数据被覆盖If WorksheetFunction.CountA(write_ws.Rows(1)) = 0 Then write_ws.Rows(1).Deletewrite_row = write_ws.UsedRange.Rows.count + 1  '合并工作表的第一个空行写入sheet_row = sht.UsedRange.Rows.countsht.Rows(title_row + 1 & ":" & sheet_row - end_row).Copy write_ws.Range("A" & write_row)End If'Exit DoNextwb.Close (False)file_name = Dir  '下一个文件名Loop'保存文件save_file = file_path & "合并表.xlsx"write_wb.SaveAs filename:=save_filewrite_wb.Close (False)Application.ScreenUpdating = TrueApplication.DisplayAlerts = True
End Sub

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

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

Sub 合并文件夹下所有工作簿中同名工作表1()'文件夹下所有工作簿wb所有工作表ws按名称合并保存至新建工作表（但不含子文件夹），但不修改原数据（工作表格式相同）Dim dict As Object, sht As Worksheet, fso As ObjectDim 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.Worksheetsdict(sht.Name) = "": [a1] = "原工作簿名称"NextDo While file_name <> ""Set wb = Workbooks.Open(file_path & file_name)For Each sht In wb.WorksheetsIf 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_nameElseSet write_ws = write_wb.Worksheets(sht.Name)If WorksheetFunction.CountA(write_ws.Rows(1)) = 0 Then write_ws.Rows(1).Deletewrite_row = write_ws.UsedRange.Rows.count + 1  '合并工作表的第一个空行写入sheet_row = sht.UsedRange.Rows.count: sheet_col = sht.UsedRange.Columns.countsht.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 IfNextwb.Close (False)file_name = Dir  '下一个文件名Loop'保存文件save_file = file_path & "合并表.xlsx"write_wb.SaveAs filename:=save_filewrite_wb.Close (False)Application.ScreenUpdating = TrueApplication.DisplayAlerts = True
End Sub