ARTICLE · 1131916
Excel VBA编程-一键拆分
Excel VBA编程-一键拆分
本期知识点来源（来自网络实战技巧）
上网搜 Excel VBA 实用技巧时，有一个办公里特别高频的痛点：一张大表里混着好多类别的数据，想按某个类别（比如"部门""地区""销售员"）拆成一张张小表，各自发给对应的人。
国外 Excel 教学站 ExcelOwl、ExcelErrorFinder、ExcelDemy 以及微软官方论坛都给出了同一个思路：按某一列的值，让 VBA 自动建新表，再把"属于这个值"的行整行搬过去。例如一张全国销售表，按"地区"一列一点，就变成"华北""华东""华南"三张表。
我们在这个思路上，今天扩展出 3 个由浅入深的实战案例。核心就三句话：找类别 → 建新表 → 搬对应行。下面三个案例全都是这个套路，只是越来越省事。
案例 1（简单）：按第 1 列（A 列）一键拆分
功能说明：你的数据第 1 列就是"类别"（比如 A 列写着部门名），运行后，VBA 会自动找出所有不同的部门，每个部门建一张表，并把对应的行整行搬过去。适合"类别就在第 1 列"的最常见情况。
代码（按 Alt + F11 打开编辑器 → 插入「标准模块」→ 粘贴下面全部内容，含最下方的函数）：
Sub 一键拆分_简单() Dim 主表 As Worksheet Dim 清单表 As Worksheet Dim 最后行 As Long, i As Long, j As Long, k As Long Dim 拆分列 As Long Dim 当前值 As String Dim 清单行 As Long Dim 已记录 As Boolean Dim 目标表 As Worksheet Dim 目标行 As Long Set 主表 = ActiveSheet 拆分列 = 1 ' 按第 1 列（A 列）拆分，要按 B 列就改成 2 最后行 = 主表.Cells(主表.Rows.Count, 拆分列).End(xlUp).Row ' 建一张临时清单表，记下出现过的不同类别 Set 清单表 = Sheets.Add 清单表.Name = "临时清单" 清单行 = 1 ' 第一遍：找出所有不同的类别 For i = 2 To 最后行 当前值 = CStr(主表.Cells(i, 拆分列).Value) If 当前值 <> "" Then 已记录 = False For j = 1 To 清单行 - 1 If CStr(清单表.Cells(j, 1).Value) = 当前值 Then 已记录 = True Exit For End If Next j If 已记录 = False Then 清单表.Cells(清单行, 1).Value = 当前值 清单行 = 清单行 + 1 End If End If Next i ' 如果以前拆过、存在同名表，先删掉，保证重新拆是干净的 Application.DisplayAlerts = False For j = 1 To 清单行 - 1 For k = Sheets.Count To 1 Step -1 If Sheets(k).Name = 清洗表名(CStr(清单表.Cells(j, 1).Value)) Then Sheets(k).Delete End If Next k Next j Application.DisplayAlerts = True ' 第二遍：每个类别建一张表，把对应的行搬过去 For j = 1 To 清单行 - 1 当前值 = CStr(清单表.Cells(j, 1).Value) Set 目标表 = Sheets.Add(After:=Sheets(Sheets.Count)) 目标表.Name = 清洗表名(当前值) 主表.Rows(1).Copy 目标表.Rows(1) ' 先搬表头 目标行 = 2 For i = 2 To 最后行 If CStr(主表.Cells(i, 拆分列).Value) = 当前值 Then 主表.Rows(i).Copy 目标表.Rows(目标行) 目标行 = 目标行 + 1 End If Next i 目标表.Columns.AutoFit Next j ' 删掉临时清单表，不在工作簿里留垃圾 Application.DisplayAlerts = False 清单表.Delete Application.DisplayAlerts = True 主表.Activate MsgBox "拆分完成！共生成 " & (清单行 - 1) & " 张表。", vbInformationEnd Sub' 把类别名整理成合法的工作表名（去掉非法符号，最长 31 字）Function 清洗表名(名称 As String) As String 清洗表名 = Replace(Replace(Replace(Replace(Replace(Replace(名称, "/", " "), "\", " "), "?", " "), "*", " "), "[", " "), "]", " ") 清洗表名 = Left(清洗表名, 31)End Function操作步骤：
在 Excel 里建一张表：第 1 行是表头（如"姓名,部门,金额"），第 1 列（A 列）写类别（如"销售部""技术部""财务部"，每个可重复多行）。 按上面建好模块、把整段代码（含下方函数）一起粘贴进去。 把光标放在 一键拆分_简单里，按F5运行（或回 Excel 按Alt + F8选它运行）。看结果：工作簿里多出了"销售部""技术部""财务部"几张表，每张只有自己部门的数据，表头也带上了。
案例 2（中等）：运行时任你选"按第几列"拆分
功能说明：案例 1 写死了"按第 1 列"。这个版本运行时弹个小框，问你"要按第几列拆分"，你输入 1、2、3……就能按任意列拆，不用改代码。更灵活，适合列位置不固定的表。
代码：
Sub 一键拆分_中等() Dim 主表 As Worksheet Dim 清单表 As Worksheet Dim 最后行 As Long, i As Long, j As Long, k As Long Dim 拆分列 As Long Dim 当前值 As String Dim 清单行 As Long Dim 已记录 As Boolean Dim 目标表 As Worksheet Dim 目标行 As Long Set 主表 = ActiveSheet ' 运行时让你输入按第几列拆分（A=1, B=2, C=3...） 拆分列 = Val(InputBox("要按第几列拆分？" & vbCrLf & "A 列输入 1，B 列输入 2，以此类推：", "选择拆分列")) If 拆分列 < 1 Then MsgBox "已取消或输入无效，请重新运行并输入数字。", vbExclamation Exit Sub End If 最后行 = 主表.Cells(主表.Rows.Count, 拆分列).End(xlUp).Row Set 清单表 = Sheets.Add 清单表.Name = "临时清单" 清单行 = 1 For i = 2 To 最后行 当前值 = CStr(主表.Cells(i, 拆分列).Value) If 当前值 <> "" Then 已记录 = False For j = 1 To 清单行 - 1 If CStr(清单表.Cells(j, 1).Value) = 当前值 Then 已记录 = True Exit For End If Next j If 已记录 = False Then 清单表.Cells(清单行, 1).Value = 当前值 清单行 = 清单行 + 1 End If End If Next i Application.DisplayAlerts = False For j = 1 To 清单行 - 1 For k = Sheets.Count To 1 Step -1 If Sheets(k).Name = 清洗表名(CStr(清单表.Cells(j, 1).Value)) Then Sheets(k).Delete End If Next k Next j Application.DisplayAlerts = True For j = 1 To 清单行 - 1 当前值 = CStr(清单表.Cells(j, 1).Value) Set 目标表 = Sheets.Add(After:=Sheets(Sheets.Count)) 目标表.Name = 清洗表名(当前值) 主表.Rows(1).Copy 目标表.Rows(1) 目标行 = 2 For i = 2 To 最后行 If CStr(主表.Cells(i, 拆分列).Value) = 当前值 Then 主表.Rows(i).Copy 目标表.Rows(目标行) 目标行 = 目标行 + 1 End If Next i 目标表.Columns.AutoFit Next j Application.DisplayAlerts = False 清单表.Delete Application.DisplayAlerts = True 主表.Activate MsgBox "拆分完成！共生成 " & (清单行 - 1) & " 张表。", vbInformationEnd SubFunction 清洗表名(名称 As String) As String 清洗表名 = Replace(Replace(Replace(Replace(Replace(Replace(名称, "/", " "), "\", " "), "?", " "), "*", " "), "[", " "), "]", " ") 清洗表名 = Left(清洗表名, 31)End Function操作步骤：
准备一张表，这次类别可能在第 2 列（B 列）或第 3 列（C 列）。 粘贴代码后按 F5运行。弹出输入框，比如类别在 B 列就输入 2，回车。立刻按你选的列拆好；弹窗告诉你生成了几张表。
案例 3（实用小案例）：拆分完再送你一张"拆分汇总"
功能说明：光拆开还不够，领导往往还要看"每个类别各多少行"。这个版本在拆完后，自动在最前面生成一张「拆分汇总」表，列出每个类别名和对应行数（用 CountIf 统计）。一发就是"各部门明细 + 一张总览"，特别适合月底分发和汇报。
代码：
Sub 一键拆分_带汇总() Dim 主表 As Worksheet Dim 清单表 As Worksheet Dim 汇总表 As Worksheet Dim 最后行 As Long, i As Long, j As Long, k As Long Dim 拆分列 As Long Dim 当前值 As String Dim 清单行 As Long Dim 已记录 As Boolean Dim 目标表 As Worksheet Dim 目标行 As Long Dim 行数 As Long Set 主表 = ActiveSheet 拆分列 = 2 ' 本例默认按第 2 列（B 列）拆分，可改成别的列 最后行 = 主表.Cells(主表.Rows.Count, 拆分列).End(xlUp).Row Set 清单表 = Sheets.Add 清单表.Name = "临时清单" 清单行 = 1 For i = 2 To 最后行 当前值 = CStr(主表.Cells(i, 拆分列).Value) If 当前值 <> "" Then 已记录 = False For j = 1 To 清单行 - 1 If CStr(清单表.Cells(j, 1).Value) = 当前值 Then 已记录 = True Exit For End If Next j If 已记录 = False Then 清单表.Cells(清单行, 1).Value = 当前值 清单行 = 清单行 + 1 End If End If Next i Application.DisplayAlerts = False For j = 1 To 清单行 - 1 For k = Sheets.Count To 1 Step -1 If Sheets(k).Name = 清洗表名(CStr(清单表.Cells(j, 1).Value)) Then Sheets(k).Delete End If Next k Next j ' 若已有一张"拆分汇总"，也先删掉 For k = Sheets.Count To 1 Step -1 If Sheets(k).Name = "拆分汇总" Then Sheets(k).Delete End If Next k Application.DisplayAlerts = True For j = 1 To 清单行 - 1 当前值 = CStr(清单表.Cells(j, 1).Value) Set 目标表 = Sheets.Add(After:=Sheets(Sheets.Count)) 目标表.Name = 清洗表名(当前值) 主表.Rows(1).Copy 目标表.Rows(1) 目标行 = 2 For i = 2 To 最后行 If CStr(主表.Cells(i, 拆分列).Value) = 当前值 Then 主表.Rows(i).Copy 目标表.Rows(目标行) 目标行 = 目标行 + 1 End If Next i 目标表.Columns.AutoFit Next j ' 生成"拆分汇总"表：类别名 + 行数 Set 汇总表 = Sheets.Add(Before:=Sheets(1)) 汇总表.Name = "拆分汇总" 汇总表.Range("A1").Value = "类别" 汇总表.Range("B1").Value = "行数" 汇总表.Range("A1:B1").Font.Bold = True For j = 1 To 清单行 - 1 当前值 = CStr(清单表.Cells(j, 1).Value) 行数 = WorksheetFunction.CountIf(主表.Range(主表.Cells(2, 拆分列), 主表.Cells(最后行, 拆分列)), 当前值) 汇总表.Cells(j + 1, 1).Value = 当前值 汇总表.Cells(j + 1, 2).Value = 行数 Next j 汇总表.Columns.AutoFit Application.DisplayAlerts = False 清单表.Delete Application.DisplayAlerts = True 主表.Activate MsgBox "拆分完成！生成 " & (清单行 - 1) & " 张明细表，外加 1 张「拆分汇总」。", vbInformationEnd SubFunction 清洗表名(名称 As String) As String 清洗表名 = Replace(Replace(Replace(Replace(Replace(Replace(名称, "/", " "), "\", " "), "?", " "), "*", " "), "[", " "), "]", " ") 清洗表名 = Left(清洗表名, 31)End Function操作步骤：
准备一张表，类别放在 B 列（想换列就改代码里的 拆分列 = 2）。粘贴代码按 F5运行。看结果：每张部门明细表照常生成；最前面还多了一张「拆分汇总」，A 列是类别、B 列是行数（例如"销售部 | 12"）。 把整本工作簿发给领导，他先看汇总、再点进明细，清清楚楚。
本篇小结
拆分核心就一句：找出拆分列里的不同类别 → 每类建一张表 → 把对应行整行搬过去。 案例 1 按固定第 1 列拆；案例 2 用 InputBox让你临时选列，更灵活；案例 3 额外生成「拆分汇总」用CountIf统计每类行数，适合汇报。Sheets.Add建新表，主表.Rows(i).Copy 目标表.Rows(目标行)整行搬运，目标表.Columns.AutoFit自动调宽列。清洗表名函数负责把类别名整理成合法表名（去掉/ \ ? * [ ]并截到 31 字），类别名里最好别带这些符号。每次运行前会自动删掉同名的旧表，所以可以反复运行、越跑越干净。
下一篇预告
Excel VBA编程-一键批量生成工资条：把一行员工信息，自动变成每人一张、带表头的工资条，批量打印不发愁。