Excel·VBA合并工作簿的实现示例
薛定谔_51 人气:01,合并文件夹下所有工作簿
适用将所有工作簿中所有工作表复制到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
到此这篇关于Excel·VBA合并工作簿的实现示例的文章就介绍到这了,更多相关Excel VBA合并工作簿内容请搜索以前的文章或继续浏览下面的相关文章希望大
加载全部内容