Excel 根据某列关键字拆分工作表

在工作中，总是会遇到这样一个需求。一张 Excel 中存在多条记录。其中某一列存贮分公司名称，需要按照分公司名称分别存贮为不同的 Excel 表。如果手工处理。分公司少还好做，但是如果数据量很大，分公司数量也较多，而且还是每天必须做的工作，我们一定会考虑使用更方便的方法。VBA 可以让 Excel 变得非常强大。下面就介绍一下如何利用 VBA 代码实现上述拆分工作。
需求为：根据G的的分公司名称拆分表格，并单独存储。如下图

1497430166820142.jpg

操作方法如下：

右键单击数据所在页的 sheet 标签。选择’查看代码’。（或者按快捷键 ALT + F11）

复制下面的代码到新打开的窗口中。

点击复制完代码的页面工具栏中的‘运行->运行子过程/用户窗体’。（或点击快捷键F5）

执行后会弹出窗口提示“请输入拆分工作表的名称：”此时输入存储数据页面的工作簿名称（通常为“sheet1”）点击确认。

弹出窗口提示“请输入拆分依据的列号（如A）：”此时按照我们的示例输入‘G’。

弹出窗口提示“请输入拆分的开始行：”此时按照2（说明：行1为标题，从行2开始为数据。因此从第二行开始拆分）。

点击确认开始拆分。

弹出“拆分工作表完成”及结束。

找到数据文件存储的路径。会发现一个名为“拆分出的表格”的文件夹。文件夹中已经保存好拆分完的表格了。[/ol]
‘来自Geeker Xu加工整理’Sub XXX_Click()‘输入用户想要拆分的工作表Dim sheet_namesheet_name = Application.InputBox(“请输入拆分工作表的名称：”)Worksheets(sheet_name).Select‘输入获取拆分需要的条件列Dim col_namecol_name = Application.InputBox(“请输入拆分依据的列号(如A):”)‘输入拆分的开始行，要求输入的是数字Dim start_row As Integerstart_row = Application.InputBox(prompt:=”请输入拆分的开始行:”, Type:=1)‘暂停屏幕更新Application.ScreenUpdating = False‘工作表的总行数Dim end_rowend_row = Worksheets(sheet_name).Range(“A65536”).End(xlUp).Row‘遍历计算所有拆分表，每个拆分表的格式为”表名称,表行数”‘对于二维数组，ReDim只能扩充最后一维，因此sheet_map行不变，扩充列Dim sheet_map(), sheet_indexReDim sheet_map(1, 0)sheet_map(0, 0) = Range(col_name & start_row).Valuesheet_map(1, 0) = 1sheet_index = 0With Worksheets(sheet_name)Dim row_count, temp, irow_count = 0For i = start_row + 1 To end_rowtemp = Range(col_name & i).ValueIf temp = Range(col_name & (i – 1)).Value Thensheet_map(1, sheet_index) = sheet_map(1, sheet_index) + 1ElseReDim Preserve sheet_map(1, sheet_index + 1)sheet_index = sheet_index + 1sheet_map(0, sheet_index) = tempsheet_map(1, sheet_index) = 1End IfNextEnd With‘根据前面计算的拆分表，拆分成单个文件Dim row_indexrow_index = start_rowFor i = 0 To sheet_indexWorkbooks.Add‘创建最终数据文件夹Dim dir_namedir_name = ThisWorkbook.Path & “\拆分出的表格\”If Dir(dir_name, vbDirectory) = “” ThenMkDir (dir_name)End If‘创建新工作簿Dim workbook_pathworkbook_path = ThisWorkbook.Path & “\拆分出的表格\” & sheet_map(0, i) & “.xlsx”ActiveWorkbook.SaveAs workbook_pathActiveSheet.Name = sheet_map(0, i)‘激活当前工作簿，ThisWorkbook表示当前跑代码的工作簿ThisWorkbook.Activate‘拷贝条目数据(即最前面不需要拆分的数据行)Dim row_rangerow_range = 1 & “:” & (start_row – 1)Worksheets(sheet_name).Rows(row_range).CopyWorkbooks(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).CopyWorkbooks(sheet_map(0, i) & “.xlsx”).Sheets(1).Range(“A” & start_row).PasteSpecialrow_index = row_index + sheet_map(1, i)‘保存文件Workbooks(sheet_map(0, i) & “.xlsx”).Close SaveChanges:=TrueNext‘进行屏幕更新Application.ScreenUpdating = TrueMsgBox “拆分工作表完成”End Sub