Excel?VBA按列拆分工作表和工作簿的實(shí)現(xiàn)
更新時(shí)間：2023年06月05日 08:43:19 作者：薛定諤_51
表格拆分是常見的數(shù)據(jù)處理，本文主要介紹了Excel?VBA按列拆分工作表和工作簿的實(shí)現(xiàn)，文中通過示例代碼介紹的非常詳細(xì)，對(duì)大家的學(xué)習(xí)或者工作具有一定的參考學(xué)習(xí)價(jià)值，需要的朋友們下面隨著小編來一起學(xué)習(xí)學(xué)習(xí)吧
改進(jìn)《將excel按照某一列拆分成多個(gè)文件》，使代碼更具通用性，可以實(shí)現(xiàn)將工作表拆分為工作表或工作簿
對(duì)Excel表格數(shù)據(jù)按照某列的值，將工作表拆分
1，工作表按列拆分為工作表
單列關(guān)鍵值
Sub 工作表按列拆分為工作表()
'當(dāng)前工作表（worksheet）按固定某列的值拆分為多個(gè)工作表，保存在當(dāng)前工作簿（workbook）
Dim arr, dict As Object
Set dict = CreateObject("scripting.dictionary")
'--------------------參數(shù)填寫：num_col，數(shù)字，A列為1向右遞增；title_row，數(shù)字，第1行為1向下遞增
num_col = 4 '關(guān)鍵值列，按該列的值進(jìn)行拆分，相同的保存在同一ws
title_row = 1 '表頭行，每個(gè)拆分后的sheet都保留
Set ws = Application.ActiveSheet
arr = ActiveSheet.UsedRange '所有數(shù)據(jù)行讀取為數(shù)組，也可arr = [a1].CurrentRegion
For i = title_row + 1 To UBound(arr): '遍歷關(guān)鍵值列，寫入字典，key為關(guān)鍵值，item為對(duì)應(yīng)的行
If Not dict.Exists(arr(i, num_col)) Then '新鍵-值
Set dict(arr(i, num_col)) = Rows(i)
Else '已有鍵-值，更新
Set dict(arr(i, num_col)) = Union(dict(arr(i, num_col)), Rows(i))
End If
Next
k = dict.Keys:v = dict.Items
For i = 0 To dict.count - 1: '遍歷字典，創(chuàng)建、寫入ws
'Worksheets.Add(after:=Sheets(Sheets.count)).Name = "拆分表" & i + 1 '最后添加新sheet，序號(hào)命名
Worksheets.Add(after:=Sheets(Sheets.count)).Name = "拆分表_" & k(i) '最后添加新sheet，keys命名
With ActiveSheet
ws.Rows(1).Copy
.[a1].PasteSpecial Paste:=xlPasteColumnWidths '復(fù)制列寬
ws.Rows(1 & ":" & title_row).Copy .[a1] '復(fù)制表頭
v(i).Copy .Range("A" & title_row + 1) '復(fù)制數(shù)據(jù)
End With
'Exit For '強(qiáng)制退出for循環(huán)，單次測(cè)試使用
Next
End Sub
2，工作表按列拆分為工作簿
單列關(guān)鍵值
Sub 工作表按列拆分為工作簿()
'當(dāng)前工作表（worksheet）按固定某列的值拆分為多個(gè)工作簿（workbook），文件單獨(dú)保存
Dim arr, dict As Object
Set dict = CreateObject("scripting.dictionary"): tm = Timer
Set fso = CreateObject("Scripting.FileSystemObject")
'--------------------參數(shù)填寫：num_col，數(shù)字，A列為1向右遞增；title_row，數(shù)字，第1行為1向下遞增
num_col = 4 '關(guān)鍵值列，按該列的值進(jìn)行拆分，相同的保存在同一ws
title_row = 1 '表頭行，每個(gè)拆分后的sheet都保留
Set ws = Application.ActiveSheet
wb_path = Application.ActiveWorkbook.Path '當(dāng)前工作簿文件路徑
wb_name = Application.ActiveWorkbook.Name '當(dāng)前工作簿文件名和擴(kuò)展名
save_path = wb_path + "\拆分表" '保存拆分后的表格保存路徑
If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path) '創(chuàng)建文件夾
Application.ScreenUpdating = False '關(guān)閉屏幕更新，加快程序運(yùn)行
Application.DisplayAlerts = False '不顯示警告信息
arr = ActiveSheet.UsedRange '所有數(shù)據(jù)行讀取為數(shù)組，也可arr = [a1].CurrentRegion
For i = title_row + 1 To UBound(arr): '遍歷關(guān)鍵值列，寫入字典，key為關(guān)鍵值，item為對(duì)應(yīng)的行
If Not dict.Exists(arr(i, num_col)) Then '新鍵-值
Set dict(arr(i, num_col)) = Rows(i)
Else '已有鍵-值，更新
Set dict(arr(i, num_col)) = Union(dict(arr(i, num_col)), Rows(i))
End If
Next
k = dict.Keys:v = dict.Items
For i = 0 To dict.count - 1: '遍歷字典，創(chuàng)建、寫入wb
Workbooks.Add
With ActiveSheet
ws.Rows(1).Copy
.[a1].PasteSpecial Paste:=xlPasteColumnWidths '復(fù)制列寬
ws.Rows(1 & ":" & title_row).Copy .[a1] '復(fù)制表頭
v(i).Copy .Range("A" & title_row + 1) '復(fù)制數(shù)據(jù)
End With
'保存文件全名（文件路徑、文件名、擴(kuò)展名），keys命名
save_file = save_path & "\" & fso.GetBaseName(wb_name) & "_拆分表_" & k(i) & "." & fso.GetExtensionName(wb_name)
ActiveWorkbook.SaveAs filename:=save_file
ActiveWorkbook.Close (False)
'Exit For '強(qiáng)制退出for循環(huán)，單次測(cè)試使用
Next
Set fso = Nothing '釋放內(nèi)存
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Debug.Print "工作表已拆分完成，累計(jì)用時(shí)" & Format(Timer - tm, "0.00") '耗時(shí)
End Sub
1、2舉例
原始數(shù)據(jù)
拆分為工作表
拆分為工作薄
3，工作簿按列拆分
對(duì)包含多個(gè)工作表的工作簿進(jìn)行拆分，支持每個(gè)工作表中關(guān)鍵值列號(hào)都不同（單列關(guān)鍵值）
3.1，復(fù)制法
Private Function RE_STR(source_str As String, pat As String, Optional replace_str As String = "$1")
'通用正則替換函數(shù)，函數(shù)定義RE(字符串，正則模式，替換值)對(duì)單元格返回正則替換后的字符串
With CreateObject("vbscript.regexp") '正則表達(dá)式
.Global = True
.Pattern = pat
RE_STR = .Replace(source_str, replace_str)
End With
End Function
Sub 工作簿按列拆分()
'當(dāng)前工作簿wb所有工作表ws按一列的值拆分為多個(gè)工作簿，新舊工作簿形式一致，以列值命名新wb
Dim arr, dict As Object, fso As Object, title_row&, num_col&, i&
'--------------------參數(shù)填寫：num_col，數(shù)字，A列為1向右遞增；title_row，數(shù)字，第1行為1向下遞增
title_row = 1 '表頭行，每個(gè)拆分后的sheet都保留
num_col = 0 '關(guān)鍵值列，按該列的值進(jìn)行拆分，相同的保存在同一ws，為0時(shí)使用key_col
key_col = "屬地" '首行關(guān)鍵值，當(dāng)各工作表關(guān)鍵值列號(hào)不同時(shí)，使用關(guān)鍵值動(dòng)態(tài)確定num_col（初始為0）
Set dict = CreateObject("scripting.dictionary"): tm = Timer
Set fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False '關(guān)閉屏幕更新，加快程序運(yùn)行
Application.DisplayAlerts = False '不顯示警告信息
With ActiveWorkbook '拆分當(dāng)前工作簿
save_path = .path + "\拆分表" '保存拆分后的表格保存路徑
wb_name = .Name '當(dāng)前工作簿文件名和擴(kuò)展名
If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path) '創(chuàng)建文件夾
For Each sht In .Worksheets
If num_col > 0 Then
col = num_col
ElseIf num_col = 0 Then '為0時(shí)使用key_col動(dòng)態(tài)確定num_col
For i = 1 To sht.UsedRange.Columns.Count
If sht.Cells(1, i).Value = key_col Then col = i
Next
End If
arr = sht.UsedRange
For i = title_row + 1 To UBound(arr) '遍歷關(guān)鍵值列，寫入字典，key為關(guān)鍵值，item為對(duì)應(yīng)的行
If Len(arr(i, col)) > 0 Then '關(guān)鍵值列不為空
If Not dict.Exists(arr(i, col)) Then '新鍵-值
Set dict(arr(i, col)) = sht.Rows(i)
Else '已有鍵-值，更新
Set dict(arr(i, col)) = Union(dict(arr(i, col)), sht.Rows(i)) 'Union,range對(duì)象
End If
End If
Next
k = dict.keys: v = dict.Items
For i = 0 To dict.Count - 1: '遍歷字典，創(chuàng)建、寫入wb
Workbooks.Add
With ActiveSheet
.Name = sht.Name '工作表命名
sht.Rows(1).Copy
.[a1].PasteSpecial Paste:=xlPasteColumnWidths '復(fù)制列寬
sht.Rows(1 & ":" & title_row).Copy .[a1] '復(fù)制表頭
v(i).Copy .Range("A" & title_row + 1) '復(fù)制數(shù)據(jù)
End With
Set ws = Application.ActiveSheet
'保存文件全名（文件路徑、文件名、擴(kuò)展名），keys命名
file_name = RE_STR(CStr(k(i)), "[\\/:*?""<>|]", "") '刪除文件名非法字符
save_file = save_path & "\" & file_name & "." & fso.GetExtensionName(wb_name)
If Not fso.FileExists(save_file) Then '文件不存在，創(chuàng)建
ActiveWorkbook.SaveAs filename:=save_file
ActiveWorkbook.Close (False)
Else '文件存在，復(fù)制
Set save_wb = Application.Workbooks.Open(save_file) '打開文件
ws.Copy After:=Sheets(save_wb.Sheets.Count)
save_wb.Close (True)
ActiveWorkbook.Close (False)
End If
Next
dict.RemoveAll '清空字典
Next
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Debug.Print "工作簿已拆分完成，累計(jì)用時(shí)" & Format(Timer - tm, "0.00") '耗時(shí)
End Sub
舉例
1個(gè)工作簿中有3個(gè)工作表，需要按照“屬地”所在列的值拆分整個(gè)工作簿
工作簿拆分結(jié)果
3.2，刪除法
以上工作簿按列拆分采用的是復(fù)制數(shù)據(jù)的方法，以下為刪除法，刪除非同一關(guān)鍵值的行。
經(jīng)測(cè)試，刪除法比原本的復(fù)制法快2倍以上，尤其是使用先Union行再刪除的方法
Sub 工作簿按列拆分_刪除法()
'當(dāng)前工作簿wb所有工作表ws按一列的值拆分為多個(gè)工作簿，新舊工作簿形式一致，以列值命名新wb
'采用刪除非同一關(guān)鍵值的方法；同時(shí)使用字典定義參數(shù)，可實(shí)現(xiàn)每個(gè)ws表頭行數(shù)與關(guān)鍵值列號(hào)都不同
Dim arr, args_dict As Object, dict As Object, fso As Object, rng As Range, t&, c&, i&
Set args_dict = CreateObject("scripting.dictionary") '參數(shù)字典
'--------------------參數(shù)填寫：字典(工作表名)= Array(表頭行數(shù), 關(guān)鍵值列號(hào))；如果工作表名未在字典中，則不拆分
args_dict("A級(jí)") = Array(1, 4): args_dict("B級(jí)") = Array(1, 3): args_dict("C級(jí)") = Array(1, 3)
Set dict = CreateObject("scripting.dictionary"): tm = Timer
Set fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False '關(guān)閉屏幕更新，加快程序運(yùn)行
Application.DisplayAlerts = False '不顯示警告信息
With ActiveWorkbook '拆分當(dāng)前工作簿
For Each sht In .Worksheets '遍歷所有工作表獲取所有關(guān)鍵值
If args_dict.Exists(sht.Name) Then '如果工作表名未在參數(shù)字典中，則不拆分
arr = sht.UsedRange: t = args_dict(sht.Name)(0): c = args_dict(sht.Name)(1)
For i = t + 1 To UBound(arr)
If Len(arr(i, c)) > 0 Then dict(arr(i, c)) = "" '關(guān)鍵值列不為空
Next
End If
Next
save_path = .path + "\拆分表" '保存拆分后的表格保存路徑
wb_name = .Name '當(dāng)前工作簿文件名和擴(kuò)展名
If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path) '創(chuàng)建文件夾
For Each k In dict.keys
Set write_wb = Workbooks.Add '新建工作簿，拆分文件
For Each sht In .Worksheets
If args_dict.Exists(sht.Name) Then
sht.Copy After:=write_wb.Worksheets(write_wb.Worksheets.Count)
With write_wb.Worksheets(write_wb.Worksheets.Count)
arr = .UsedRange: t = args_dict(sht.Name)(0): c = args_dict(sht.Name)(1)
For i = t + 1 To UBound(arr)
If arr(i, c) <> k Then
If rng Is Nothing Then
Set rng = .Rows(i)
Else
Set rng = Union(rng, .Rows(i))
End If
End If
Next
rng.Delete: Set rng = Nothing '刪除非同一關(guān)鍵值的行，清空變量
End With
End If
Next
write_wb.Worksheets(1).Delete 'excel新建wb第1個(gè)ws為空表
'保存文件全名（文件路徑、文件名、擴(kuò)展名），keys命名
file_name = RE_STR(CStr(k), "[\\/:*?""<>|]", "") '刪除文件名非法字符
save_file = save_path & "\" & file_name & "." & fso.GetExtensionName(wb_name)
write_wb.SaveAs filename:=save_file
write_wb.Close (False)
Next
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Debug.Print "工作簿已拆分完成，累計(jì)用時(shí)" & Format(Timer - tm, "0.00") '耗時(shí)
End Sub
4，工作表按列拆分，支持多列關(guān)鍵值
如果需要對(duì)數(shù)據(jù)按多列關(guān)鍵值合并進(jìn)行拆分，可以選擇添加輔助列，先將多列的值合并，在使用以上sub進(jìn)行拆分；也可以重新定義一個(gè)sub既支持單列又支持多列關(guān)鍵值的
Sub 工作表按列拆分_多列關(guān)鍵值()
'當(dāng)前工作表ws按固定多列的值拆分為多個(gè)工作表，文件保存在當(dāng)前工作簿wb同一文件夾下單獨(dú)文件夾內(nèi)
'采用刪除法；關(guān)鍵值可單列、多列；可拆分為工作表或工作簿
Dim arr, dict As Object, fso As Object, rng As Range, i&, t&, b&, bb&, k$, ws_name$, file_name$
'--------------------參數(shù)填寫：key_col，列號(hào)數(shù)組，數(shù)字
title_row = 1 '表頭行，每個(gè)拆分后的sheet都保留
key_col = Array(2, 4) '關(guān)鍵值列，按該列的值進(jìn)行拆分，相同的保存在同一ws
delimiter = "_" '分隔符，最好為數(shù)據(jù)中不存在的字符，如Chr(28)或|
save_type = "wb" '保存方式：ws拆分為工作表，wb拆分為工作簿
ReDim temp(1 To UBound(key_col) - LBound(key_col) + 1)
Set dict = CreateObject("scripting.dictionary"): tm = Timer
Set fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False '關(guān)閉屏幕更新，加快程序運(yùn)行
Application.DisplayAlerts = False '不顯示警告信息
With ActiveSheet
arr = .UsedRange: ReDim brr(1 To UBound(arr) - title_row) 'brr保存關(guān)鍵字
For i = title_row + 1 To UBound(arr) '遍歷所有工作表獲取所有關(guān)鍵值
t = 0
For Each c In key_col
t = t + 1: temp(t) = arr(i, c)
Next
k = Join(temp, delimiter): b = b + 1: brr(b) = k
dict(k) = ""
Next
If save_type = "ws" Then '拆分為工作表
For Each kk In dict.keys
ws_name = Replace(kk, delimiter, "_") '將分隔符改為下劃線
ws_name = RE_STR(ws_name, "[\\/:*?""<>|]", "") '刪除文件名非法字符
.Copy after:=Worksheets(Worksheets.Count) '復(fù)制到最后，keys命名
With ActiveSheet
crr = .UsedRange: bb = 0: .Name = ws_name
For i = title_row + 1 To UBound(arr)
bb = bb + 1
If brr(bb) <> kk Then
If rng Is Nothing Then
Set rng = .Rows(i)
Else
Set rng = Union(rng, .Rows(i))
End If
End If
Next
rng.Delete: Set rng = Nothing '刪除非同一關(guān)鍵值的行，清空變量
End With
Next
ElseIf save_type = "wb" Then '拆分為工作簿
save_path = .Parent.path + "\拆分表" '保存拆分后的表格保存路徑
wb_name = .Parent.Name '當(dāng)前工作簿文件名和擴(kuò)展名
If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path) '創(chuàng)建文件夾
For Each kk In dict.keys
Set write_wb = Workbooks.Add '新建工作簿，拆分文件
.Copy after:=write_wb.Worksheets(write_wb.Worksheets.Count)
With write_wb.Worksheets(write_wb.Worksheets.Count)
crr = .UsedRange: bb = 0
For i = title_row + 1 To UBound(arr)
bb = bb + 1
If brr(bb) <> kk Then
If rng Is Nothing Then
Set rng = .Rows(i)
Else
Set rng = Union(rng, .Rows(i))
End If
End If
Next
rng.Delete: Set rng = Nothing '刪除非同一關(guān)鍵值的行，清空變量
End With
write_wb.Worksheets(1).Delete 'excel新建wb第1個(gè)ws為空表
'保存文件全名（文件路徑、文件名、擴(kuò)展名），keys命名
file_name = Replace(kk, delimiter, "_") '將分隔符改為下劃線
file_name = RE_STR(file_name, "[\\/:*?""<>|]", "") '刪除文件名非法字符
save_file = save_path & "\" & file_name & "." & fso.GetExtensionName(wb_name)
write_wb.SaveAs filename:=save_file
write_wb.Close (False)
Next
End If
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Debug.Print "工作表已拆分完成，累計(jì)用時(shí)" & Format(Timer - tm, "0.00") '耗時(shí)
End Sub
注意：
關(guān)鍵值列最好不存在為空的單元格，如果分隔符delimiter也為空的話，可能導(dǎo)致關(guān)鍵值錯(cuò)誤進(jìn)而拆分錯(cuò)誤，比如
b1和c1為空值，textjoin分隔符為空則導(dǎo)致關(guān)鍵值d1和d2相同，為避免這種情況delimiter最好不為空，且為數(shù)據(jù)中不存在的字符，避免最后replace導(dǎo)致保存文件名出錯(cuò)
舉例
原始數(shù)據(jù)
拆分為工作簿
到此這篇關(guān)于Excel·VBA按列拆分工作表和工作簿的實(shí)現(xiàn)的文章就介紹到這了,更多相關(guān)Excel VBA按列拆分內(nèi)容請(qǐng)搜索腳本之家以前的文章或繼續(xù)瀏覽下面的相關(guān)文章希望大家以后多多支持腳本之家！
您可能感興趣的文章:
相關(guān)文章
用vba實(shí)現(xiàn)將記錄集輸出到Excel模板
用vba實(shí)現(xiàn)將記錄集輸出到Excel模板...2007-02-02
本文主要介紹了VBA中的循環(huán)代碼的使用，文中通過示例代碼介紹的非常詳細(xì)，對(duì)大家的學(xué)習(xí)或者工作具有一定的參考學(xué)習(xí)價(jià)值，需要的朋友們下面隨著小編來一起學(xué)習(xí)學(xué)習(xí)吧2023-06-06
VBA處理數(shù)據(jù)與Python Pandas處理數(shù)據(jù)案例比較分析
這篇文章主要介紹了VBA處理數(shù)據(jù)與Python Pandas處理數(shù)據(jù)案例比較,本文通過實(shí)例代碼給大家介紹的非常詳細(xì)，具有一定的參考借鑒價(jià)值，需要的朋友可以參考下2020-04-04
excel vba 限制工作表的滾動(dòng)區(qū)域代碼
如果希望限制工作表中滾動(dòng)的區(qū)域，可以通過設(shè)置WorkSheet對(duì)象的ScrollArea屬性來實(shí)現(xiàn)。2009-07-07
用條件格式設(shè)置高亮顯示當(dāng)前行，難的是如何確定當(dāng)前行。用VBA就很簡(jiǎn)單，鼠標(biāo)右擊工作表標(biāo)簽，選擇“查看代碼”，將下面的代碼粘貼到VBE窗口中2009-07-07
本文給大家分享的是使用VBA解決Windows空當(dāng)接龍的617局的方法和思路，有需要的小伙伴可以參考下。2015-09-09
VBA 中要用到的常數(shù)...2007-02-02
向數(shù)據(jù)報(bào)表添加一個(gè)合計(jì)字段
在數(shù)據(jù)環(huán)境設(shè)計(jì)器中也可以創(chuàng)建一個(gè)合計(jì)字段，即對(duì)來自部分的數(shù)據(jù)進(jìn)行合計(jì)的字段。2009-07-07
本文給大家匯總介紹了幾種使用VBA處理EXCEL并生成JSON文件的方法和思路，非常的實(shí)用，有需要的小伙伴可以參考下。2015-09-09
今天遇到一個(gè)excel小工具感覺不錯(cuò)，想研究研究代碼，竟然有密碼，我就不淡定了。網(wǎng)上找了找代碼，改了一下就OK了。接下來通過本文給大家分享兩種方式破解VBA工程加密，需要的朋友參考下吧2021-12-12