Excel·VBA按列拆分工作表、工作簿
改进《将excel按照某一列拆分成多个文件》,使代码更具通用性,可以实现将工作表拆分为工作表或工作簿
对Excel表格数据按照某列的值,将工作表拆分
目录
- 1,工作表按列拆分为工作表
- 2,工作表按列拆分为工作簿
- 1、2举例
- 3,工作簿按列拆分
- 举例
1,工作表按列拆分为工作表
Sub 工作表按列拆分为工作表()'当前工作表(worksheet)按固定某列的值拆分为多个工作表,保存在当前工作簿(workbook)Dim arr, dict As ObjectSet dict = CreateObject("scripting.dictionary")
'--------------------参数填写:num_col,数字,A列为1向右递增;title_row,数字,第1行为1向下递增num_col = 4 '关键值列,按该列的值进行拆分,相同的保存在同一wstitle_row = 1 '表头行,每个拆分后的sheet都保留Set ws = Application.ActiveSheetarr = ActiveSheet.UsedRange '所有数据行读取为数组,也可arr = [a1].CurrentRegionFor 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 IfNextk = dict.Keysv = dict.ItemsFor 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 ActiveSheetws.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循环,单次测试使用NextEnd Sub
2,工作表按列拆分为工作簿
Sub 工作表按列拆分为工作簿()'当前工作表(worksheet)按固定某列的值拆分为多个工作簿(workbook),文件单独保存tm = TimerApplication.Visible = False '后台运行,不显示界面Application.DisplayAlerts = False '不显示警告信息Dim arr, dict As ObjectSet dict = CreateObject("scripting.dictionary")Set fso = CreateObject("Scripting.FileSystemObject")
'--------------------参数填写:num_col,数字,A列为1向右递增;title_row,数字,第1行为1向下递增num_col = 4 '关键值列,按该列的值进行拆分,相同的保存在同一wstitle_row = 1 '表头行,每个拆分后的sheet都保留Set ws = Application.ActiveSheetwb_path = Application.ActiveWorkbook.Path '当前工作簿文件路径wb_name = Application.ActiveWorkbook.Name '当前工作簿文件名和扩展名save_path = wb_path + "\拆分表" '保存拆分后的表格保存路径If fso.FolderExists(save_path) ThenDebug.Print ("拆分文件保存路径已存在:" & save_path)Elsefso.CreateFolder (save_path)Debug.Print ("拆分文件保存路径已创建:" & save_path)End Ifarr = ActiveSheet.UsedRange '所有数据行读取为数组,也可arr = [a1].CurrentRegionFor 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 IfNextk = dict.Keysv = dict.ItemsFor i = 0 To dict.count - 1: '遍历字典,创建、写入wbWorkbooks.AddWith ActiveSheetws.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_fileActiveWorkbook.Close (False)'Exit For '强制退出for循环,单次测试使用NextSet fso = Nothing '释放内存Application.Visible = TrueApplication.DisplayAlerts = TrueDebug.Print "工作表已拆分完成,累计用时" & Format(Timer - tm, "0.00") '耗时End Sub
1、2举例
原始数据
拆分为工作表
拆分为工作薄
3,工作簿按列拆分
对包含多个工作表的工作簿进行拆分,支持每个工作表中关键值列号都不同
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 = patRE_STR = .Replace(source_str, replace_str)End With
End FunctionSub 工作簿按列拆分()'当前工作簿wb所有工作表ws按一列的值拆分为多个工作簿,新旧工作簿形式一致,以列值命名新wbDim 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_colkey_col = "属地" '首行关键值,当各工作表关键值列号不同时,使用关键值动态确定num_col(初始为0)tm = TimerSet dict = CreateObject("scripting.dictionary")Set fso = CreateObject("Scripting.FileSystemObject")Application.Visible = 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 .WorksheetsIf num_col > 0 Thencol = num_colElseIf num_col = 0 Then '为0时使用key_col动态确定num_colFor i = 1 To sht.UsedRange.Columns.CountIf sht.Cells(1, i).Value = key_col Then col = iNextEnd Ifarr = sht.UsedRangeFor 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 IfEnd IfNextk = dict.keys: v = dict.ItemsFor i = 0 To dict.Count - 1: '遍历字典,创建、写入wbWorkbooks.AddWith 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 WithSet 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_fileActiveWorkbook.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 IfNextdict.RemoveAll '清空字典NextEnd WithApplication.Visible = TrueApplication.DisplayAlerts = TrueDebug.Print "工作簿已拆分完成,累计用时" & Format(Timer - tm, "0.00") '耗时
End Sub
举例
1个工作簿中有3个工作表,需要按照“属地”所在列的值拆分整个工作簿
工作簿拆分结果
以上工作簿按列拆分采用的是复制数据的方法,以下为删除法,删除非同一关键值的行。
经测试,删除法比原本的复制法快2倍以上,尤其是使用先Union行再删除的方法
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)tm = TimerSet dict = CreateObject("scripting.dictionary")Set fso = CreateObject("Scripting.FileSystemObject")Application.Visible = 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)) = "" '关键值列不为空NextEnd IfNextsave_path = .path + "\拆分表" '保存拆分后的表格保存路径wb_name = .Name '当前工作簿文件名和扩展名If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path) '创建文件夹For Each k In dict.keysSet write_wb = Workbooks.Add '新建工作簿,拆分文件For Each sht In .WorksheetsIf args_dict.Exists(sht.Name) Thensht.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 ThenIf rng Is Nothing ThenSet rng = .Rows(i)ElseSet rng = Union(rng, .Rows(i))End IfEnd IfNextrng.Delete: Set rng = Nothing '删除非同一关键值的行,清空变量End WithEnd IfNextwrite_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_filewrite_wb.Close (False)NextEnd WithApplication.Visible = TrueApplication.DisplayAlerts = TrueDebug.Print "工作簿已拆分完成,累计用时" & Format(Timer - tm, "0.00") '耗时
End Sub
Excel·VBA按列拆分工作表、工作簿相关推荐
- excel根据某列拆分数据表
问题描述 现excel表格,要根据某列数据,拆分成不同的文件.如图 解决办法一 选中所有数据 点击[数据]-[数据透析表]在弹框中选择[新工作表]点击[确定]按钮 把要按照分组的字段 点击,然后拖动到 ...
- Excel·VBA按行拆分工作表
对应之前文章<Excel·VBA按列拆分工作表>,对Excel表格数据按照固定行数,将工作表拆分 工作表按行拆分为工作表 Sub 工作表按行拆分为工作表()'当前工作表(worksheet ...
- 【Excel VBA】批量拆分工作表为独立文件批量复制文件内容到总文件的工作表
一.将一个工作簿中所有工作表单独保存为独立的文件 操作过程分三步:选中要复制的sheet,,复制(建立副本),保存后关闭新文件 Sub sheet2file()Dim sht As Worksheet ...
- 【Excel VBA】批量新建并重命名工作表
一.需求 根据sheet1所列名称,添加并重命名新的工作表. 二.实现 1.按照从前往后的顺序 Sub cre_ren_sheets()Dim num% /* 定义为integer*/num = Ap ...
- excel之工作表工作簿保护暴力撤销
excel可以在审阅中设置工作表.工作簿的密码保护,但是当密码忘记或一些特殊情况下需要进行操作. 1.工作簿保护撤销 步骤一:将需要破解的excal文件后缀名改为rar 步骤二:用压缩软件打开文件可以 ...
- Excel VBA 高级编程-库存管理系统表
大家好,我是陈小虾,是一名自动化方向的IT民工.写博客是为了记录自己的学习过程,通过不断输出倒逼自己加速成长.但功能说明:由于水平有限,博客中难免会出现一些BUG,或者有更优方案恳请各位大佬不吝赐教! ...
- Excel·VBA选中列一键计算小计总计
不同于<Excel·VBA一键计算每月合计>,仅对指定关键字计算合计数,而本文可以实现对选中列自动插入小计.总计行并求和 目录 连续相同关键值自动小计 举例 固定行数分段自动小计 连续相同 ...
- Excel按相同列内容合并表
需求:输出strings.xml多语言对照表 工具:WPS 前提:两表之间有相同列 来源:表A,表B strings.xml通过wps打开,直接将xml读取成表格 注意:出现读取失败,检查资源文件是否 ...
- Excel VBA 根据单元格内容更改工作表名称
Public Sub 更改名称()For i = 2 To Worksheets.CountWorksheets(i).Name = Worksheets("目录").Cells( ...
最新文章
- Gromacs 5.1.4 在CentOS7下GPU加速版的安装
- python 数组基本用法
- oracle 10g/11g 命令对照,日志文件夹对照
- SAP成都研究院2018年年会之前的技术讲座
- oracle行转列 case,Oracle 行转列总结 Case When,Decode,PIVOT 三种方式
- 啊这,C++现在学还来的及吗?
- vue 单文件组件中,输入template 按 tab 键不能自动补全标签的解决办法
- Java回调函数实现案例
- 十天学会php之第九天
- html中电脑自动输入,电脑一直自动打字怎么办
- win10系统如何查询本机的IP地址和外网IP地址
- Typora加超链接实现页内跳转的三种方法
- 低效程序员的9个坏习惯
- 惊 腾讯云、阿里云服务器无需备案配置域名访问方法
- java.lang.ClassNotFoundException: org.springframework.boot.actuate.autoconfigure.endpoint.web.WebEnd
- 视觉基础:关于机器视觉、机器学习及人工智能领域
- 【2022秋招】IC设计/FPGA开发秋招经历总结(2)——公司专题
- 基于 Metal 框架的 GPU 计算
- Apollo坐标系转换
- 【BZOJ2427】【HAOI2010】软件安装(树形依赖背包,缩点)
热门文章
- 电机型号如YE2-132M-4-7.5KW-B35(B3)
- 局域网共享文件夹/共享文件夹无法访问解决办法
- 擅长To C的腾讯,如何借腾讯云在这几个行业云市场占有率第一? ...
- LR(1)分析法的总控的实现(C++实现)
- 微信支付和支付宝支付整合(含设计模式1)
- Android 下标圆点数字
- 2021涅普冬令营Misc笔记与题解
- 共享充电宝投放餐饮行业收益如何?
- echarts 图例翻页+图例自定义样式
- 【Android开发】android最全的颜色对应的16进制代码(androidUI设计必备)