如下圖，需要将下表中的内容，依據部門拆分，每個部門各成一個工作簿：
圖 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