Excel？VBA按列拆分工作表和工作簿的实现（vba拆分单元格代码）越早知道越好

目录1，工作表按列拆分为工作表2，工作表按列拆分为工作簿3，工作簿按列拆分3.1，复制法3.2，删除法4，工作表按列拆分，支持多列关键值

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

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

Private Function RE_STR(source_str As String, pat As String, Optional replace_str As String=”$1″) ‘通用正则替换函数，函数定义RE(字符串，正则模式，替换值)对单元格返回正则替换后的字符串 With CreateObject(“vbscript.regexp”) ‘正则表达式 .Global=True .Pattern=pat RE_STR=.Replace(source_str, replace_str) End With End Function 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

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 rng.Delete: Set rng=Nothing ‘删除非同一关键值的行，清空变量 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

Sub 工作表按列拆分_多列关键值() ‘当前工作表ws按固定多列的值拆分为多个工作表，文件保存在当前工作簿wb同一文件夹下单独文件夹内 ‘采用删除法；关键值可单列、多列；可拆分为工作表或工作簿 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拆分为工作簿 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) 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) ‘复制到最后，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 ‘删除非同一关键值的行，清空变量 End With Next ElseIf save_type=”wb” Then ‘拆分为工作簿 save_path=.Parent.path + “\拆分表” ‘保存拆分后的表格保存路径 wb_name=.Parent.Name ‘当前工作簿文件名和扩展名 If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path) ‘创建文件夹 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 ‘删除非同一关键值的行，清空变量 End With write_wb.Worksheets(1).Delete ‘excel新建wb第1个ws为空表 ‘保存文件全名（文件路径、文件名、扩展名），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 “工作表已拆分完成，累计用时” & Format(Timer – tm, “0.00”) ‘耗时 End Sub

您可能感兴趣的文章:vba将excel按照某一列拆分成多个文件