如下图，需要将下表中的内容，依据部门拆分，每个部门各成一个工作簿：
图 1 需求说明
针对上述需求，专门设计了一个拆分工具。操作步骤如下：
Step1：确定拆分后工作簿的存储位置： 图 2 表格拆分后存储位置
操作时，会在B2单元对应的路径下，生成一个文件夹（名称为B1单元格内容）。拆分后工作簿都存储在其中。
Step2：将待拆分内容存储在拆分工具“data”工作表中： 图 3 确定贷拆分内容
Step3：确定拆分“data”工作表中内容时所依据所在列： 图 4 确定拆分依据所在列
Step4：点击"开始拆分
"按钮： 图 5 选择开始拆分
拆分后结果：
图 6 拆分后结果
具体操作过程如下：
知乎视频www.zhihu.com
对应代码为：
Sub 拆分表格()
Dim w, j, k As Integer
Dim rng As Range
Dim strrng, strkey, strpath, strdepart, filename As String
Dim savepath As String
Dim wb As Workbook
'------------------------------------------------------------------------------------------------提取主键清单
strkey = ThisWorkbook.Sheets("配置").Range("B3")
w = ThisWorkbook.Sheets("data").Range(strkey & 65536).End(xlUp).Row
strrng = ThisWorkbook.Sheets("配置").Range("B3") & "1:B" & w
filename = ThisWorkbook.Sheets("配置").Range("B1").Value
ThisWorkbook.Sheets("辅助").Cells.Clear
Set rng = ThisWorkbook.Sheets("data").Range(strrng)
rng.AdvancedFilter Action:=xlFilterCopy, Unique:=True, copytorange:=ThisWorkbook.Sheets("辅助").Range("A1")
Set rng = Nothing
savepath = ThisWorkbook.Sheets("配置").Range("B2") & ThisWorkbook.Sheets("配置").Range("B1")
With ThisWorkbook.Sheets("data").Range("A1").CurrentRegion
'------------------------------------------------------------------------------------------------新建文件夹
If Dir(savepath, vbDirectory) <> "" Then
MsgBox "表格拆分文件已存在"
Else
MkDir savepath
MsgBox "文件夹创建成功"
End If
'------------------------------------------------------------------------------------------------拆分表格
k = ThisWorkbook.Sheets("辅助").Range("A65536").End(xlUp).Row
strpath = savepath
ThisWorkbook.Sheets("辅助").Range("B1") = ThisWorkbook.Sheets("辅助").Range("A1")
For j = 2 To k
ThisWorkbook.Sheets("辅助").Range("B2") = ThisWorkbook.Sheets("辅助").Range("A" & j)
Set wb = Workbooks.Add
ThisWorkbook.Activate
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=ThisWorkbook.Sheets("辅助").Range("B1:B2"), copytorange:=wb.Sheets(1).Range("A1")
wb.Sheets(1).Cells.Columns.AutoFit
wb.SaveAs strpath & "" & ThisWorkbook.Sheets("辅助").Range("B2") & ".xlsx"
wb.Close
Set wb = Nothing
ThisWorkbook.Sheets("辅助").Range("B2").ClearContents
Next j
End With
End Sub