Excel·VBA合并工作簿的實現(xiàn)示例
更新時間：2023年06月05日 08:41:59 作者：薛定諤_51
本文主要介紹了Excel·VBA合并工作簿的實現(xiàn)示例，文中通過示例代碼介紹的非常詳細，對大家的學(xué)習(xí)或者工作具有一定的參考學(xué)習(xí)價值，需要的朋友們下面隨著小編來一起學(xué)習(xí)學(xué)習(xí)吧
1，合并文件夾下所有工作簿
適用將所有工作簿中所有工作表復(fù)制到1個新建工作簿中，不修改數(shù)據(jù)，原本一共有多少個工作表，合并后就有多少個工作表
如果存在同名工作表，復(fù)制后工作表名稱會自動添加序號，如Sheet1 (2)
Sub 合并文件夾下所有工作簿()
'文件夾下所有工作簿wb所有工作表ws合并為一個新工作簿（但不含子文件夾），不修改數(shù)據(jù)
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 '關(guān)閉屏幕更新，加快程序運行
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合并為一個新工作簿（但不含子文件夾），不修改數(shù)據(jù)，并建立目錄超鏈接
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 '關(guān)閉屏幕更新，加快程序運行
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 '可對復(fù)制的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 '列寬自適應(yīng)
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拆分后的工作表
并且每個工作簿中的工作表復(fù)制1個副本（1個地名表1個Sheet1表），這樣就有5個工作簿各含2個工作表
工作簿合并且建立超鏈接目錄結(jié)果
2，合并工作簿中所有工作表
對工作簿中相同格式的工作表進行合并，匯總所有工作表，保存在工作簿最前
2.1，縱向合并
Sub 合并工作簿中所有工作表_縱向()
'當(dāng)前工作簿wb所有工作表ws合并保存至新建工作表（插入最前），但之前ws不修改（工作表格式相同）
Dim wb, ws, title_row, end_row, copy_title, i
'--------------------參數(shù)填寫：title_row，數(shù)字，第1行為1向下遞增；end_row，數(shù)字
title_row = 1 '表頭行數(shù)，僅復(fù)制1次；如果為0，則表示沒有表頭或表頭每次都復(fù)制
end_row = 0 '表尾行數(shù)，不參與合并
Set wb = Application.ActiveWorkbook '當(dāng)前工作簿即為待合并工作簿
Set ws = wb.Worksheets.Add(before:=Sheets(1)) '最前添加新sheet，即為合并工作表
ws.Name = "合并表"
If title_row > 0 Then copy_title = True Else copy_title = False '是否復(fù)制表頭
If title_row < 0 Then Debug.Print "title_row參數(shù)錯誤，必須為>=0的整數(shù)": Exit Sub
Application.ScreenUpdating = False '關(guān)閉屏幕更新，加快程序運行
Application.DisplayAlerts = False '不顯示警告信息
'遍歷，復(fù)制表體
For i = 1 To Worksheets.count:
If Worksheets(i).Name <> ws.Name Then
If copy_title = True Then '復(fù)制表頭，僅執(zhí)行1次
Worksheets(i).Rows(1 & ":" & title_row).Copy ws.Range("A1")
copy_title = False
End If
'首行為空，會導(dǎo)致后續(xù)數(shù)據(jù)被覆蓋
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拆分后的工作表
合并參數(shù)：title_row = 1，end_row = 0
2.2，橫向合并
Sub 合并工作簿中所有工作表_橫向()
'當(dāng)前工作簿wb所有工作表ws合并保存至新建工作表（插入最前），但之前ws不修改（工作表格式相同）
Dim ws As Worksheet, sht As Worksheet, write_col&
Application.ScreenUpdating = False '關(guān)閉屏幕更新，加快程序運行
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
'首列為空時，會導(dǎo)致后續(xù)數(shù)據(jù)被覆蓋
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合并保存至新建工作表（但不含子文件夾），但不修改原數(shù)據(jù)（工作表格式相同）
Dim wb, ws, title_row, end_row, copy_title, file_path, file_name, save_file, i
'--------------------參數(shù)填寫：title_row，數(shù)字，第1行為1向下遞增；end_row，數(shù)字；file_path，合并文件夾
title_row = 1 '表頭行數(shù)，僅復(fù)制1次；如果為0，則表示沒有表頭或表頭每次都復(fù)制
end_row = 0 '表尾行數(shù)，不參與合并
file_path = "E:\測試\拆分表\" '待合并工作簿所在的文件夾
file_name = Dir(file_path & "*.xlsx")
If title_row > 0 Then copy_title = True Else copy_title = False '是否復(fù)制表頭
If title_row < 0 Then Debug.Print "title_row參數(shù)錯誤，必須為>=0的整數(shù)": Exit Sub
Application.ScreenUpdating = False '關(guān)閉屏幕更新，加快程序運行
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 '復(fù)制表頭，僅執(zhí)行1次
wb.Worksheets(i).Rows(1 & ":" & title_row).Copy ws.Range("A1")
copy_title = False
End If
'首行為空，會導(dǎo)致后續(xù)數(shù)據(jù)被覆蓋
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拆分后的工作表
合并參數(shù)：title_row = 0，end_row = 0
3.1，合并且顯示原工作簿名稱、原工作表名稱
應(yīng)評論建議，增加在A列顯示原工作簿名稱，B列顯示原工作表名稱
Sub 合并文件夾下所有工作簿中所有工作表1()
'文件夾下所有工作簿wb所有工作表ws合并保存至新建工作表（但不含子文件夾），但不修改原數(shù)據(jù)（工作表格式相同）
Dim wb, ws, title_row, end_row, copy_title, file_path, file_name, save_file, fso As Object
'--------------------參數(shù)填寫：title_row，數(shù)字，第1行為1向下遞增；end_row，數(shù)字；file_path，合并文件夾
title_row = 1 '表頭行數(shù)，僅復(fù)制1次；如果為0，則表示沒有表頭或表頭每次都復(fù)制
end_row = 0 '表尾行數(shù)，不參與合并
file_path = "E:\測試\拆分表\" '待合并工作簿所在的文件夾
file_name = Dir(file_path & "*.xlsx")
If title_row > 0 Then copy_title = True Else copy_title = False '是否復(fù)制表頭
If title_row < 0 Then Debug.Print "title_row參數(shù)錯誤，必須為>=0的整數(shù)": Exit Sub
Application.ScreenUpdating = False '關(guān)閉屏幕更新，加快程序運行
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 '復(fù)制表頭，僅執(zhí)行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按名稱合并保存至新建工作表（但不含子文件夾），但不修改原數(shù)據(jù)（工作表格式相同）
Dim dict As Object, sht As Worksheet, file_path$, file_name$, title_row, end_row, save_file$
'--------------------參數(shù)填寫：title_row，數(shù)字，第1行為1向下遞增；end_row，數(shù)字；file_path，合并文件夾
title_row = 1 '表頭行數(shù)，不參與合并
end_row = 0 '表尾行數(shù)，不參與合并
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 '新建工作簿，合并文件
'新建工作簿默認(rèn)工作表，防止有同名被合并表，導(dǎo)致整表復(fù)制后名稱改變；但會缺少表頭
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 '不存在的，直接復(fù)制整表
dict(sht.Name) = ""
sht.Copy After:=write_wb.Sheets(write_wb.Sheets.count)
Else
Set write_ws = write_wb.Worksheets(sht.Name)
'首行為空，會導(dǎo)致后續(xù)數(shù)據(jù)被覆蓋
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，合并且顯示原工作簿名稱
應(yīng)評論建議，增加在A列顯示原工作簿名稱；因按同名工作表合并，故沒有顯示原工作表名稱的必要
Sub 合并文件夾下所有工作簿中同名工作表1()
'文件夾下所有工作簿wb所有工作表ws按名稱合并保存至新建工作表（但不含子文件夾），但不修改原數(shù)據(jù)（工作表格式相同）
Dim dict As Object, sht As Worksheet, fso As Object
Dim file_path$, file_name$, title_row, end_row, save_file$
'--------------------參數(shù)填寫：title_row，數(shù)字，第1行為1向下遞增；end_row，數(shù)字；file_path，合并文件夾
title_row = 1 '表頭行數(shù)，不參與合并
end_row = 0 '表尾行數(shù)，不參與合并
file_path = "E:\測試\拆分表\" '待合并工作簿所在的文件夾
file_name = Dir(file_path & "*.xlsx")
Application.ScreenUpdating = False '關(guān)閉屏幕更新，加快程序運行
Application.DisplayAlerts = False '不顯示警告信息
Set fso = CreateObject("Scripting.FileSystemObject")
Set dict = CreateObject("scripting.dictionary")
Set write_wb = Workbooks.Add '新建工作簿，合并文件
'新建工作簿默認(rèn)工作表，防止有同名被合并表，導(dǎo)致整表復(fù)制后名稱改變；但會缺少表頭
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 '不存在的，直接復(fù)制整表
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
到此這篇關(guān)于Excel·VBA合并工作簿的實現(xiàn)示例的文章就介紹到這了,更多相關(guān)Excel VBA合并工作簿內(nèi)容請搜索腳本之家以前的文章或繼續(xù)瀏覽下面的相關(guān)文章希望大
相關(guān)文章
本文給大家分享的是使用VBA解決Windows空當(dāng)接龍的617局的方法和思路，有需要的小伙伴可以參考下。2015-09-09
用條件格式設(shè)置高亮顯示當(dāng)前行，難的是如何確定當(dāng)前行。用VBA就很簡單，鼠標(biāo)右擊工作表標(biāo)簽，選擇“查看代碼”，將下面的代碼粘貼到VBE窗口中2009-07-07
今天遇到一個excel小工具感覺不錯，想研究研究代碼，竟然有密碼，我就不淡定了。網(wǎng)上找了找代碼，改了一下就OK了。接下來通過本文給大家分享兩種方式破解VBA工程加密，需要的朋友參考下吧2021-12-12
本文主要介紹了vba將excel按照某一列拆分成多個文件，文中通過示例代碼介紹的非常詳細，對大家的學(xué)習(xí)或者工作具有一定的參考學(xué)習(xí)價值，需要的朋友們下面隨著小編來一起學(xué)習(xí)學(xué)習(xí)吧<BR>2023-01-01
在數(shù)據(jù)環(huán)境設(shè)計器中也可以創(chuàng)建一個合計字段，即對來自部分的數(shù)據(jù)進行合計的字段。2009-07-07
如果希望限制工作表中滾動的區(qū)域，可以通過設(shè)置WorkSheet對象的ScrollArea屬性來實現(xiàn)。2009-07-07
本文主要介紹了VBA中Excel宏的介紹及應(yīng)用，文中通過示例代碼介紹的非常詳細，對大家的學(xué)習(xí)或者工作具有一定的參考學(xué)習(xí)價值，需要的朋友們下面隨著小編來一起學(xué)習(xí)學(xué)習(xí)吧2023-05-05
VBA 瀏覽文件夾對話框調(diào)用實現(xiàn)代碼。大家可以根據(jù)需要選擇。2009-07-07
表格拆分是常見的數(shù)據(jù)處理，本文主要介紹了Excel?VBA按列拆分工作表和工作簿的實現(xiàn)，文中通過示例代碼介紹的非常詳細，對大家的學(xué)習(xí)或者工作具有一定的參考學(xué)習(xí)價值，需要的朋友們下面隨著小編來一起學(xué)習(xí)學(xué)習(xí)吧2023-01-01
VBA數(shù)組去重(字典去重多種方法+數(shù)組去重2種方法)
本文主要介紹了VBA數(shù)組去重(字典去重多種方法+數(shù)組去重2種方法),文中通過示例代碼介紹的非常詳細,對大家的學(xué)習(xí)或者工作具有一定的參考學(xué)習(xí)價值,需要的朋友們下面隨著小編來一起學(xué)習(xí)學(xué)習(xí)吧2023-08-08