目录
代码使用说明
- 代码作用范围：以下代码作用于活动工作簿/工作表，无需将需要拆分的数据保存在启用宏的工作簿中（xlsm格式），只要待拆分表格处于活动状态即可运行代码。同时，也不建议把数据保存在xlsm文件中，vba代码运行结果是无法撤销的
活动工作簿：如果打开多个工作簿，显示在最前面的就是活动工作簿；活动工作表：活动工作簿当前显示的工作表 - 代码使用建议：工作表拆分使用
方法4，工作簿拆分使用方法3.3；其他几个版本的代码写法较为原始，仅供代码学习参考 - 扩展名自动获取：以下代码中拆分为工作簿的，使用了自动获取扩展名，是为了方便可同时对xls和xlsx格式拆分。如果无需使用此功能的，可以将代码中的
fso.GetExtensionName(wb_name)改为"xlsx"，但方法3.3无需此操作 - RE_STR函数说明：工作簿和工作表的名称中不得包含
\/:*?"<>|字符，以下代码使用RE_STR函数删除这些字符。如果能够明确待拆分数据中不包含这些字符的，可以将代码中带有RE_STR的行删除；否则使用代码必须复制本函数，避免报错
方法3.2：带有RE_STR的行删除后，原文代码第50行中的file_name需要改为CStr(k)
方法3.3：带有RE_STR的行删除后，原文代码第46行中的file_name需要改为CStr(k)
方法4：仅需删除带有RE_STR的行
Function RE_STR(ByVal source_str$, pat$, Optional replace_str$ = "$1")
'通用正则替换函数，函数定义RE(字符串，正则模式，替换值)对单元格返回正则替换后的字符串
With CreateObject("vbscript.regexp") '正则表达式
.Global = True
.Pattern = pat
RE_STR = .Replace(source_str, replace_str)
End With
End Function
1，工作表按列拆分为工作表
改进《将excel按照某一列拆分成多个文件》，使代码更具通用性，可以实现将工作表拆分为工作表或工作簿，仅支持单列关键值
Sub 工作表按列拆分为工作表()
'当前工作表（worksheet）按固定某列的值拆分为多个工作表，保存在当前工作簿（workbook）
Dim arr, dict As Object
Set dict = CreateObject("scripting.dictionary")
'--------------------参数填写：num_col，数字，A列为1向右递增；title_row，数字，第1行为1向下递增
num_col = 4 '关键值列，按该列的值进行拆分，相同的保存在同一ws
title_row = 1 '表头行，每个拆分后的sheet都保留
Set ws = Application.ActiveSheet
arr = ActiveSheet.UsedRange '所有数据行读取为数组，也可arr = [a1].CurrentRegion
For i = title_row + 1 To UBound(arr): '遍历关键值列，写入字典，key为关键值，item为对应的行
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: '遍历字典，创建、写入ws
'Worksheets.Add(after:=Sheets(Sheets.count)).Name = "拆分表" & i + 1 '最后添加新sheet，序号命名
Worksheets.Add(after:=Sheets(Sheets.count)).Name = "拆分表_" & k(i) '最后添加新sheet，keys命名
With ActiveSheet
ws.Rows(1).Copy
.[a1].PasteSpecial Paste:=xlPasteColumnWidths '复制列宽
ws.Rows(1 & ":" & title_row).Copy .[a1] '复制表头
v(i).Copy .Range("A" & title_row + 1) '复制数据
End With
'Exit For '强制退出for循环，单次测试使用
Next
End Sub
2，工作表按列拆分为工作簿
单列关键值
Sub 工作表按列拆分为工作簿()
'当前工作表（worksheet）按固定某列的值拆分为多个工作簿（workbook），文件单独保存
Dim arr, dict As Object
Set dict = CreateObject("scripting.dictionary"): tm = Timer
Set fso = CreateObject("Scripting.FileSystemObject")
'--------------------参数填写：num_col，数字，A列为1向右递增；title_row，数字，第1行为1向下递增
num_col = 4 '关键值列，按该列的值进行拆分，相同的保存在同一ws
title_row = 1 '表头行，每个拆分后的sheet都保留
Set ws = Application.ActiveSheet
wb_path = Application.ActiveWorkbook.Path '当前工作簿文件路径
wb_name = Application.ActiveWorkbook.Name '当前工作簿文件名和扩展名
save_path = wb_path + "\拆分表\" '保存拆分后的表格保存路径
If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path) '创建文件夹
Application.ScreenUpdating = False '关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False '不显示警告信息
arr = ActiveSheet.UsedRange '所有数据行读取为数组，也可arr = [a1].CurrentRegion
For i = title_row + 1 To UBound(arr): '遍历关键值列，写入字典，key为关键值，item为对应的行
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: '遍历字典，创建、写入wb
Workbooks.Add
With ActiveSheet
ws.Rows(1).Copy
.[a1].PasteSpecial Paste:=xlPasteColumnWidths '复制列宽
ws.Rows(1 & ":" & title_row).Copy .[a1] '复制表头
v(i).Copy .Range("A" & title_row + 1) '复制数据
End With
'保存文件全名（文件路径、文件名、扩展名），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 '强制退出for循环，单次测试使用
Next
Set fso = Nothing '释放内存
Application.ScreenUpdating = True: Application.DisplayAlerts = True
Debug.Print "工作表已拆分完成，累计用时" & Format(Timer - tm, "0.00") '耗时
End Sub
1、2举例
原始数据
拆分为工作表
拆分为工作薄
3，工作簿按列拆分
对包含多个工作表的工作簿进行拆分，支持每个工作表中关键值列号都不同（单列关键值）
3.1，复制法
Sub 工作簿按列拆分()
'当前工作簿wb所有工作表ws按一列的值拆分为多个工作簿，新旧工作簿形式一致，以列值命名新wb
Dim arr, dict As Object, fso As Object, title_row&, num_col&, i&
'--------------------参数填写：num_col，数字，A列为1向右递增；title_row，数字，第1行为1向下递增
title_row = 1 '表头行，每个拆分后的sheet都保留
num_col = 0 '关键值列，按该列的值进行拆分，相同的保存在同一ws，为0时使用key_col
key_col = "属地" '首行关键值，当各工作表关键值列号不同时，使用关键值动态确定num_col（初始为0）
Set dict = CreateObject("scripting.dictionary"): tm = Timer
Set fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False '关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False '不显示警告信息
With ActiveWorkbook '拆分当前工作簿
save_path = .path + "\拆分表\" '保存拆分后的表格保存路径
wb_name = .Name '当前工作簿文件名和扩展名
If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path) '创建文件夹
For Each sht In .Worksheets
If num_col > 0 Then
col = num_col
ElseIf num_col = 0 Then '为0时使用key_col动态确定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) '遍历关键值列，写入字典，key为关键值，item为对应的行
If Len(arr(i, col)) > 0 Then '关键值列不为空
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对象
End If
End If
Next
k = dict.keys: v = dict.Items
For i = 0 To dict.Count - 1: '遍历字典，创建、写入wb
Workbooks.Add
With ActiveSheet
.Name = sht.Name '工作表命名
sht.Rows(1).Copy
.[a1].PasteSpecial Paste:=xlPasteColumnWidths '复制列宽
sht.Rows(1 & ":" & title_row).Copy .[a1] '复制表头
v(i).Copy .Range("A" & title_row + 1) '复制数据
End With
Set ws = Application.ActiveSheet
'保存文件全名（文件路径、文件名、扩展名），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 '文件不存在，创建
ActiveWorkbook.SaveAs filename:=save_file
ActiveWorkbook.Close (False)
Else '文件存在，复制
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 "工作簿已拆分完成，累计用时" & Format(Timer - tm, "0.00") '耗时
End Sub
举例
1个工作簿中有3个工作表，需要按照“属地”所在列的值拆分整个工作簿
工作簿拆分结果
3.2，删除法
以上工作簿按列拆分采用的是复制数据的方法，以下为删除法，删除非同一关键值的行。
经测试，删除法比原本的复制法快2倍以上，尤其是使用先Union行再删除的方法
2023.4.17更新，应评论建议
为避免某个工作表仅存在单一关键值而无需执行删除操作导致报错的，更新增加if判断以避免
同时在某个工作表执行删除操作后仅有表头行的空表情况，更新增加删除此类空表
Sub 工作簿按列拆分_删除法()
'当前工作簿wb所有工作表ws按一列的值拆分为多个工作簿，新旧工作簿形式一致，以列值命名新wb
'采用删除非同一关键值的方法；同时使用字典定义参数，可实现每个ws表头行数与关键值列号都不同
Dim arr, args_dict As Object, dict As Object, fso As Object, rng As Range, t&, c&, i&
Set args_dict = CreateObject("scripting.dictionary") '参数字典
'--------------------参数填写：字典(工作表名)= Array(表头行数, 关键值列号)；如果工作表名未在字典中，则不拆分
args_dict("A级") = Array(1, 4): args_dict("B级") = Array(1, 3): args_dict("C级") = Array(1, 3)
Set dict = CreateObject("scripting.dictionary"): tm = Timer
Set fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False '关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False '不显示警告信息
With ActiveWorkbook '拆分当前工作簿
For Each sht In .Worksheets '遍历所有工作表获取所有关键值
If args_dict.Exists(sht.Name) Then '如果工作表名未在参数字典中，则不拆分
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)) = "" '关键值列不为空
Next
End If
Next
save_path = .path + "\拆分表\" '保存拆分后的表格保存路径
wb_name = .Name '当前工作簿文件名和扩展名
If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path) '创建文件夹
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
'删除非同一关键值的行，清空变量；删除仅有表头的空表
If Not rng Is Nothing Then rng.Delete: Set rng = Nothing
If .UsedRange.Rows.Count = t Then .Delete
End With
End If
Next
write_wb.Worksheets(1).Delete 'excel新建wb第1个ws为空表
'保存文件全名（文件路径、文件名、扩展名），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 "工作簿已拆分完成，累计用时" & Format(Timer - tm, "0.00") '耗时
End Sub
3.3，删除法，改进版
2023.10.21更新，在方法3.2的删除法的基础上，与方法4的工作表整体复制相结合——经测试，删除法改进版比原版快1倍以上
2023.12.29更新，应评论建议
对关键列中错误值不进行拆分，忽略错误值所在列，避免报错，错误值包含非字符串类型的#N/A、#DIV/0!、#VALUE!等
Sub 工作簿按列拆分_删除法2()
'当前工作簿wb所有工作表ws按一列的值拆分为多个工作簿，新旧工作簿形式一致，以列值命名新wb
Dim arr, args_dict As Object, dict As Object, fso As Object, rng As Range, t&, c&, i&
Dim sht As Worksheet, write_wb As Workbook, save_path$, file_name$, srr, k
Set args_dict = CreateObject("scripting.dictionary") '参数字典
'--------------------参数填写：字典(工作表名)= Array(表头行数, 关键值列号)；如果工作表名未在字典中，则不拆分
args_dict("A级") = Array(1, 4): args_dict("B级") = Array(1, 3): args_dict("C级") = Array(1, 3)
Set dict = CreateObject("scripting.dictionary"): tm = Timer
Set fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False '关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False '不显示警告信息
With ActiveWorkbook '拆分当前工作簿
For Each sht In .Worksheets '遍历所有工作表获取所有关键值
If args_dict.Exists(sht.Name) Then '如果工作表名未在参数字典中，则不拆分
arr = sht.UsedRange: t = args_dict(sht.Name)(0): c = args_dict(sht.Name)(1)
For i = t + 1 To UBound(arr)
If TypeName(arr(i, c)) <> "Error" Then
If Len(arr(i, c)) > 0 Then dict(arr(i, c)) = "" '关键值列不为空
End If
Next
End If
Next
save_path = .path + "\拆分表\" '保存拆分后的表格保存路径
srr = args_dict.keys '需要拆分的工作表名称数组，注意args_dict中不能有工作簿中不存在的工作表
If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path) '创建文件夹
For Each k In dict.keys
.Worksheets(srr).Copy: Set write_wb = ActiveWorkbook '整体复制工作表
For Each sht In write_wb.Worksheets
arr = sht.UsedRange: t = args_dict(sht.Name)(0): c = args_dict(sht.Name)(1)
For i = t + 1 To UBound(arr)
If TypeName(arr(i, c)) = "Error" Then arr(i, c) = "" '错误值改为空值，便于判断拆分
If arr(i, c) <> k Then
If rng Is Nothing Then
Set rng = sht.Rows(i)
Else
Set rng = Union(rng, sht.Rows(i))
End If
End If
Next
'删除非同一关键值的行，清空变量；删除仅有表头的空表
If Not rng Is Nothing Then rng.Delete: Set rng = Nothing
If sht.UsedRange.Rows.Count = t Then sht.Delete
Next
'保存文件全名（文件路径、文件名、扩展名），keys命名
file_name = RE_STR(CStr(k), "[\\/:*?""<>|]", "") '删除文件名非法字符
write_wb.SaveAs filename:=save_path & file_name & ".xlsx"
write_wb.Close (False)
Next
End With
Application.ScreenUpdating = True: Application.DisplayAlerts = True
Debug.Print "工作簿已拆分完成，累计用时" & Format(Timer - tm, "0.00") '耗时
End Sub
4，工作表按列拆分，支持多列关键值
如果需要对数据按多列关键值合并进行拆分，可以选择添加辅助列，先将多列的值合并，在使用以上sub进行拆分；也可以重新定义一个sub既支持单列又支持多列关键值的
2023.4.29更新，应评论建议
对工作表ws拆分为工作簿wb，可在keep_ws数组中指定ws名称，使得每个wb都保留指定名称的ws，以保证拆分后的表格内公式正常使用。经测试表1中vlookup可以正常获取表2的结果
2023.12.29更新，应评论建议
对关键列中错误值转换为空值处理，避免报错，如果按单列关键值进行拆分，那么错误值不会生成拆分结果；如果按多列关键值进行拆分，那么会以错误值转换为空值后的整体为字典键，生成拆分结果。错误值包含非字符串类型的#N/A、#DIV/0!、#VALUE!等
Sub 工作表按列拆分_多列关键值()
'当前工作表ws按固定多列的值拆分为多个工作表，文件保存在当前工作簿wb同一文件夹下单独文件夹内
'采用删除法；关键值可单列、多列；可拆分为工作表或工作簿；增加拆分为wb固定保留指定ws
Dim arr, dict As Object, fso As Object, rng As Range, i&, t&, b&, bb&, k$, ws_name$, file_name$
'--------------------参数填写：key_col，列号数组，数字
title_row = 1 '表头行，每个拆分后的sheet都保留
key_col = Array(2, 4) '关键值列，按该列的值进行拆分，相同的保存在同一ws
delimiter = "_" '分隔符，最好为数据中不存在的字符，如Chr(28)或|
save_type = "wb" '保存方式：ws拆分为工作表，wb拆分为工作簿
keep_ws = Array("数据源") '拆分为wb，需固定保留指定ws名称，无需保留的参数为空数组
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 '关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False '不显示警告信息
With ActiveSheet
arr = .UsedRange: ReDim brr(1 To UBound(arr) - title_row) 'brr保存关键字
For i = title_row + 1 To UBound(arr) '遍历所有工作表获取所有关键值
t = 0
For Each c In key_col
t = t + 1: temp(t) = arr(i, c)
If TypeName(temp(t)) = "Error" Then temp(t) = "" '避免错误值报错
Next
k = Join(temp, delimiter): b = b + 1: brr(b) = k
If Len(k) > 0 Then 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) '复制到最后，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
If Not rng Is Nothing Then rng.Delete: Set rng = Nothing '删除非同一关键值的行，清空变量
End With
Next
ElseIf save_type = "wb" Then '拆分为工作簿
save_path = .Parent.path + "\拆分表\" '保存拆分后的表格保存路径
ws_name = .Name: wb_name = .Parent.Name '当前ws、wb名称
If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path) '创建文件夹
For Each kk In dict.keys
If UBound(keep_ws) = -1 Then '无需保留固定ws
.Copy 'ws在copy后自动生成一个新建wb
Else
s = Join(keep_ws, Chr(28)) & Chr(28) & ws_name '字符串拼接
srr = Split(s, Chr(28)) '需复制的ws名称数组
.Parent.Worksheets(srr).Copy '工作表整体复制
End If
With ActiveWorkbook.Worksheets(ws_name)
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
If Not rng Is Nothing Then rng.Delete: Set rng = Nothing
End With
'保存文件全名（文件路径、文件名、扩展名），keys命名
file_name = Replace(kk, delimiter, "_") '将分隔符改为下划线
file_name = RE_STR(file_name, "[\\/:*?""<>|]", "") '删除文件名非法字符
save_file = save_path & file_name & "." & fso.GetExtensionName(wb_name)
ActiveWorkbook.SaveAs filename:=save_file
ActiveWorkbook.Close (False)
Next
End If
End With
Application.ScreenUpdating = True: Application.DisplayAlerts = True
Debug.Print "工作表已拆分完成，累计用时" & Format(Timer - tm, "0.00") '耗时
End Sub
注意：
关键值列最好不存在为空的单元格，如果分隔符delimiter也为空的话，可能导致关键值错误进而拆分错误，比如
b1和c1为空值，textjoin分隔符为空则导致关键值d1和d2相同，为避免这种情况delimiter最好不为空，且为数据中不存在的字符，避免最后replace导致保存文件名出错
举例
原始数据
拆分为工作簿
5，工作表按列拆分，先拆分为工作簿再拆分为工作表
如果需要对数据按1列关键值拆分为工作簿，再按另1列关键值拆分为工作表，可以使用方法4分2步操作运行代码，也可以重新定义一个sub一次性拆分数据
Sub 工作表按列拆分_先拆分为工作簿再拆分为工作表()
'当前工作表ws按一列的值拆分为多个工作簿，再按另一列的值拆分为多个工作表，文件保存在当前工作簿wb同一文件夹下单独文件夹内
'采用删除法；拆分结果可保留指定名称的ws；关键值列忽略错误值、空值
Dim dict1 As Object, dict2 As Object, fso As Object, rng As Range
Dim title_row&, wb&, ws&, keep_ws, arr, brr, i&, ws_name$, s$, srr, k, kk
'--------------------参数填写：title_row，wb，ws，keep_ws
title_row = 1 '表头行，每个拆分后的sheet都保留
wb = 3: ws = 4 '关键值列号，按wb列拆分为工作簿，按ws列拆分为工作表
keep_ws = Array("数据源") '拆分为工作簿后需要保留的指定ws名称，无需保留的参数为空数组（同一工作簿内）
Set dict1 = CreateObject("scripting.dictionary")
Set dict2 = CreateObject("scripting.dictionary")
Set fso = CreateObject("Scripting.FileSystemObject"): tm = Timer
Application.ScreenUpdating = False '关闭屏幕更新，加快程序运行
Application.DisplayAlerts = False '不显示警告信息
With ActiveSheet '拆分当前工作表
save_path = .Parent.path + "\拆分表\" '保存拆分后的表格保存路径
If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path) '创建文件夹
arr = .UsedRange: ws_name = .Name
For i = title_row + 1 To UBound(arr) '遍历获取所有关键值
If TypeName(arr(i, wb)) <> "Error" Then
If Len(arr(i, wb)) > 0 Then dict1(arr(i, wb)) = "" '关键值不为空
Else
arr(i, wb) = "" '错误值改为空值，便于判断拆分
End If
Next
For Each k In dict1.keys
If UBound(keep_ws) = -1 Then '无需保留固定ws
.Copy 'ws在copy后自动生成一个新建wb
Else
s = Join(keep_ws, Chr(28)) & Chr(28) & ws_name '字符串拼接
srr = Split(s, Chr(28)) '需复制的ws名称数组
.Parent.Worksheets(srr).Copy '工作表整体复制
End If
With ActiveWorkbook.Worksheets(ws_name) '------拆分为工作簿
For i = title_row + 1 To UBound(arr)
If arr(i, wb) <> k Then
If rng Is Nothing Then
Set rng = .Rows(i)
Else
Set rng = Union(rng, .Rows(i))
End If
End If
Next
If Not rng Is Nothing Then rng.Delete: Set rng = Nothing '删除非同一关键值的行，清空变量
brr = .UsedRange '------拆分为工作表
For i = title_row + 1 To UBound(brr)
If TypeName(brr(i, ws)) <> "Error" Then
If Len(brr(i, ws)) > 0 Then dict2(brr(i, ws)) = ""
Else
brr(i, ws) = ""
End If
Next
For Each kk In dict2.keys
.Copy after:=Worksheets(.Parent.Worksheets.Count) '复制到最后，keys命名
With ActiveSheet
.Name = kk
For i = title_row + 1 To UBound(brr)
If brr(i, ws) <> kk Then
If rng Is Nothing Then
Set rng = .Rows(i)
Else
Set rng = Union(rng, .Rows(i))
End If
End If
Next
If Not rng Is Nothing Then rng.Delete: Set rng = Nothing
End With
Next
dict2.RemoveAll '清空字典
'保存文件全名（文件路径、文件名、扩展名），keys命名
.Parent.SaveAs filename:=save_path & k & ".xlsx"
.Parent.Close (False)
End With
Next
End With
Application.ScreenUpdating = True: Application.DisplayAlerts = True
Debug.Print "工作表已拆分完成，累计用时" & Format(Timer - tm, "0.00") '耗时
End Sub
举例
原始数据
拆分结果
3990
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
