别再复制粘贴了!一键将Excel总表按条件拆分成独立文件(附完整代码)

被Excel折磨了10年，这个“体力活”终于有解了！

作为一名和Excel打了多年交道的职场人，有一件事前几年我一直没整明白：如何把一个总表，根据“单位名称”自动拆分成多个独立文件？

我知道这需求很普遍，也知道VBA大概率能实现。但在当年，我搜了某度、某乎教程，复制了各种看着靠谱的代码，最后都被各种报错劝退。每次面对各单位的报表拆分，我只能认命地手动筛选、复制、新建工作簿、另存为……一套流程下来，手酸眼疼不说，还生怕漏了哪家。

昨天，我抱着试一试的心态，把需求抛给了某AI。

万万没想到，一次就跑通了！

那种瞬间解放双手的快乐，真的很难形容。如果你也一直被这个问题困扰，一定要把这篇收藏起来，不用懂代码，照做就行。

代码能帮你做什么？

1. 根据“单位名称”列，把数据拆分成多个工作表
2. 将每个工作表单独保存为一个Excel文件，文件名就用单位名称命名
3. 所有文件集中存放在你指定的文件夹内

超详细操作步骤

1. 备份数据（重要！先用副本测试）
2. 打开你的总表，按 Alt + F11 进入VBA编辑器
3. 菜单点击 插入 → 模块，将下方代码完整粘贴进去
4. 修改代码开头的两个参数：
  · SavePath：改成你希望保存文件的文件夹路径
  · ColName：如果你的单位名称列标题不叫“单位名称”，改成实际的标题名
5. 关闭VBA编辑器，回到Excel，按 Alt + F8，选择 SplitDataByCompany，点击“执行”
6. 去保存文件夹查看，所有子公司的独立文件已生成

VBA代码

```vba
Sub SplitDataByCompany()
   Dim ws As Worksheet
   Dim rngData As Range
   Dim rngCell As Range
   Dim dict As Object
   Dim key As Variant
   Dim wbNew As Workbook
   Dim wsNew As Worksheet
   Dim lastRow As Long
   Dim lastCol As Long
   Dim headerRow As Range
   Dim colCompany As Range
   Dim companyColIndex As Long
   Dim savePath As String
   Dim companyName As String
   Dim fileName As String
   
   '============= 用户需修改的参数 =============
   savePath = "C:\子公司报表\"   '保存文件夹路径，请确保文件夹已存在
   Const ColName As String = "单位名称"  '包含单位名称的列标题
   '==========================================
   
   Set ws = ActiveSheet   '使用当前活动的工作表，也可指定如 ThisWorkbook.Sheets("Sheet1")
   
   '找到单位名称所在的列
   Set colCompany = ws.Rows(1).Find(What:=ColName, LookAt:=xlWhole, MatchCase:=False)
   If colCompany Is Nothing Then
       MsgBox "找不到标题为 """ & ColName & """ 的列，请检查！", vbExclamation
       Exit Sub
   End If
   companyColIndex = colCompany.Column
   
   '确定数据范围（假设第一行为标题，数据从第二行开始）
   lastRow = ws.Cells(ws.Rows.Count, companyColIndex).End(xlUp).Row
   If lastRow < 2 Then
       MsgBox "数据表中没有数据！", vbExclamation
       Exit Sub
   End If
   lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
   Set rngData = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol))
   Set headerRow = ws.Range(ws.Cells(1, 1), ws.Cells(1, lastCol))
   
   '用字典收集所有不重复的单位名称
   Set dict = CreateObject("Scripting.Dictionary")
   For Each rngCell In ws.Range(ws.Cells(2, companyColIndex), ws.Cells(lastRow, companyColIndex))
       If Not IsEmpty(rngCell) Then
           companyName = Trim(rngCell.Value)
           If Len(companyName) > 0 Then
               dict(companyName) = 1
           End If
       End If
   Next rngCell
   
   If dict.Count = 0 Then
       MsgBox "单位名称列没有有效数据！", vbExclamation
       Exit Sub
   End If
   
   '关闭屏幕更新和警告，加快运行速度
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   
   '遍历每个单位，筛选并保存
   For Each key In dict.Keys
       companyName = CStr(key)
       '处理文件名中的非法字符
       fileName = Replace(Replace(Replace(Replace(Replace(companyName, "\", ""), "/", ""), ":", ""), "*", ""), "?", "")
       fileName = Replace(Replace(fileName, "[", ""), "]", "")
       
       '复制标题行和筛选出的数据
       rngData.AutoFilter Field:=companyColIndex, Criteria1:=companyName
       rngData.SpecialCells(xlCellTypeVisible).Copy
       
       '新建工作簿，粘贴数据
       Set wbNew = Workbooks.Add
       Set wsNew = wbNew.Worksheets(1)
       wsNew.Paste
       wsNew.Cells.EntireColumn.AutoFit   '自动调整列宽
       
       '保存并关闭新工作簿
       wbNew.SaveAs Filename:=savePath & fileName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
       wbNew.Close False
   Next key
   
   '清除筛选
   ws.AutoFilterMode = False
   
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   
   MsgBox "拆分完成！文件已保存到：" & savePath, vbInformation
End Sub
```

---

写在最后

那种差点摆烂但最后终于把一件事搞定的感觉，真的很痛快。希望这份快乐和这个代码，也能帮你从繁琐的复制粘贴中解脱出来。有问题欢迎评论区交流，如果觉得有用，记得转发给身边还在手动拆表的同事。