Excel·VBA合并工作簿的实现示例（vba合并工作簿代码）这样也行？

🌐 经济型：买域名、轻量云服务器、用途：游戏网站等《腾讯云》特点：特价机便宜适合初学者用点我优惠购买

🚀 拓展型：买域名、轻量云服务器、用途：游戏网站等《阿里云》特点：中档服务器便宜域名备案事多点我优惠购买

🛡️ 稳定型：买域名、轻量云服务器、用途：游戏网站等《西部数码》特点：比上两家略贵但是稳定性超好事也少点我优惠购买

目录1，合并文件夹下所有工作簿1.1，合并且建立超链接目录2，合并工作簿中所有工作表2.1，纵向合并2.2，横向合并3，合并文件夹下所有工作簿中所有工作表3.1，合并且显示原工作簿名称、原工作表名称4，合并文件夹下所有工作簿中同名工作表4.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

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个工作表

工作簿合并且建立超链接目录结果

在这里插入图片描述

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

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

在这里插入图片描述

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

举例

合并前

在这里插入图片描述

合并后

在这里插入图片描述

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

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

在这里插入图片描述

应评论建议，增加在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

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

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

应评论建议，增加在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合并工作簿内容请搜索脚本之家以前的文章或继续浏览下面的相关文章希望大

您可能感兴趣的文章:Excel?VBA指定条件删除整行整列的实现Excel?VBA按列拆分工作表和工作簿的实现vba将excel按照某一列拆分成多个文件VBA将excel数据表生成JSON文件VBA中操作Excel常用方法总结Excel VBA连接并操作Oracleexcel vba 高亮显示当前行代码excel vba 限制工作表的滚动区域代码合并Excel工作薄中成绩表的VBA代码，非常适合教育一线的朋友用vba实现将记录集输出到Excel模板