指定条件拆分Excel工作表(VBA版)
经常跟Excel打交道的人,相信或多或少会遇到这样一个问题:
一张大的汇总表,需要按某一列的值(如部门名称)拆分成多个Excel文件,然后分发给各个部门。
如果部门数较多的话,一个个去复制粘贴就太没效率了。
因为工作关系,每天都要跟一堆数据打交道,所以这里,我就分享一个通用一点的方法——使用Excel宏。
将一个Excel工作表拆分成多个Excel文件
Sub 拆分成多个工作簿() '输入用户想要拆分的工作表 Dim sheet_name sheet_name = Application.InputBox("请输入拆分工作表的名称:") Worksheets(sheet_name).Select '输入获取拆分需要的条件列 Dim col_name col_name = Application.InputBox("请输入拆分依据的列号(如A):") '输入拆分的开始行,要求输入的是数字 Dim start_row As Integer start_row = Application.InputBox(prompt:="请输入拆分的开始行:", Type:=1) '暂停屏幕更新 Application.ScreenUpdating = False '工作表的总行数 Dim end_row end_row = Worksheets(sheet_name).UsedRange.Rows.Count '遍历计算所有拆分表,每个拆分表的格式为"表名称,表行数" '对于二维数组,ReDim只能扩充最后一维,因此sheet_map行不变,扩充列 Dim sheet_map(), sheet_index ReDim sheet_map(1, 0) sheet_map(0, 0) = Range(col_name & start_row).Value sheet_map(1, 0) = 1 sheet_index = 0 With Worksheets(sheet_name) Dim row_count, temp, i row_count = 0 For i = start_row + 1 To end_row temp = Range(col_name & i).Value If temp = Range(col_name & (i - 1)).Value Then sheet_map(1, sheet_index) = sheet_map(1, sheet_index) + 1 Else ReDim Preserve sheet_map(1, sheet_index + 1) sheet_index = sheet_index + 1 sheet_map(0, sheet_index) = temp sheet_map(1, sheet_index) = 1 End If Next End With '根据前面计算的拆分表,拆分成单个文件 Dim row_index row_index = start_row For i = 0 To sheet_index Workbooks.Add '创建最终数据文件夹 Dim dir_name dir_name = ThisWorkbook.Path & "\拆分出的表格\" If Dir(dir_name, vbDirectory) = "" Then MkDir (dir_name) End If '创建新工作簿 Dim workbook_path workbook_path = ThisWorkbook.Path & "\拆分出的表格\" & sheet_map(0, i) & ".xlsx" ActiveWorkbook.SaveAs workbook_path ActiveSheet.Name = sheet_map(0, i) '激活当前工作簿,ThisWorkbook表示当前跑代码的工作簿 ThisWorkbook.Activate '拷贝条目数据(即最前面不需要拆分的数据行) Dim row_range row_range = 1 & ":" & (start_row - 1) Worksheets(sheet_name).Rows(row_range).Copy Workbooks(sheet_map(0, i) & ".xlsx").Sheets(1).Range("A1").PasteSpecial '拷贝拆分表的专属数据 row_range = row_index & ":" & (row_index + sheet_map(1, i) - 1) Worksheets(sheet_name).Rows(row_range).Copy Workbooks(sheet_map(0, i) & ".xlsx").Sheets(1).Range("A" & start_row).PasteSpecial row_index = row_index + sheet_map(1, i) '保存文件 Workbooks(sheet_map(0, i) & ".xlsx").Close SaveChanges:=True Next '进行屏幕更新 Application.ScreenUpdating = True MsgBox "拆分工作表完成" End Sub
将一个Excel工作表拆分成多个工作表
Sub 拆分成多个工作表() Dim Arr, Rng As Range, Sht As Worksheet, Dic As Object Dim k, t, Str As String, i As Long, lc As Long '输入获取拆分需要的条件列 Dim col_name col_name = Application.InputBox("请输入拆分依据的列号(如:第一列,输入:1):") Application.ScreenUpdating = False '关闭屏幕更新 Arr = Range("A1").CurrentRegion.Value lc = UBound(Arr, 2) '求取最后一列的列号 Set Rng = Rows(1) '标题行 Set Dic = CreateObject("Scripting.Dictionary") '创建字典 For i = 2 To UBound(Arr) Str = Arr(i, col_name) '条件列,关键字 If Not Dic.Exists(Str) Then '如果字典没有关键字 Set Dic(Str) = Cells(i, 1).Resize(, lc) '把当前行装入到字典中 Else '否则(字典中存在关键字) Set Dic(Str) = Union(Dic(Str), Cells(i, 1).Resize(, lc)) '把行连合起来 End If Next k = Dic.Keys '字典关键字集合 t = Dic.Items '字典项目集合 On Error Resume Next With Sheets For i = 0 To Dic.Count - 1 '循环关键字的个数 Set Sht = .Item(k(i)) '给变量赋值(工作表名为关键字) If Sht Is Nothing Then '该工作表不存在则插入一个空工作表 .Add(After:=.Item(.Count)).Name = k(i) '新建的工作表将置于所有工作表之后,并命名为关键字 Set Sht = ActiveSheet '活动工作表给变量 Else '否则 Sht.Cells.Clear '清除工作中所有内容和格式 End If Rng.Copy Sht.Range("A1") '把标题写入第一行 t(i).Copy Sht.Range("A2") '写入其他内容 Sht.Cells.EntireColumn.AutoFit '自动调整全工作表单元格的列宽 Set Sht = Nothing '变量处于初始状态 Next End With Sheets(1).Activate '第1个工作表处于激活状态 Application.ScreenUpdating = True '打开屏幕更新 MsgBox "拆分工作表完成" End Sub
因为近期自己也在自学Python,后面会分享另一种方法,使用Python来完成这个项任务。
共有 0 条评论