用VBA拆分工作表是一個不錯的方法，特別是在處理大量資料的時候，能節省不少時間。

1、高階篩選： 篩選並複製到新工作表的關鍵程式碼如下： Range("Database").AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=Range("Criteria"), _ CopyToRange:=Range("Paste"), _ Unique:=False 該程式碼執行結果是將Database區域的資料按照Criteria區域條件篩選，並貼上到Paste區域。 AdvancedFilter(Action, [CriteriaRange], [CopyToRange], [Unique])是VBA中對Range物件進行篩選的方法：Action引數可以填xlFilterInPlace或xlFilterCopy，前者是直接進行篩選，後者是我們這次用到的篩選並複製功能；CriteriaRange是篩選條件的區域；CopyToRange是貼上到的區域（如果Action引數為xlFilterInPlace則不填）；Unique引數是布林型，用來選擇是否只保留一條重複記錄。 這裡需要詳細說明的是CriteriaRange引數： 篩選條件區域至少為兩行，首行為列標題，與原記錄中的列標題要一致。 同一行中，各列之間是AND邏輯 不同行之間是OR邏輯 如果標題行不一致或者出現空行，則全選 因為CriteriaRange引數要求如此嚴格，所以我們在對錶格資料進行篩選時會用兩個臨時單元格存放需要篩選的資料。 Sheet1.Range("ZZ2")=critTitle Sheet1.Range("ZZ3")=critValue 這裡為了防止干擾已有資料，把臨時資料放在了702列，從第2行開始是為了不影響UsedRange的使用。如果覺得這樣不保險也可以用以下方法來獲取最後一行和最後一列： Dim rowCount%, colCount% colCount = Sheet1.Range("XFD1").End(xlToLeft).Column '獲取最後一列 rowCount = Sheet1.Range("A1048576").End(xlUp).Row '獲取最後一行 然後用Range(Cells(1, 1), Cells(rowCount, colCount))代替UsedRange，理論上這樣是更符合邏輯的。 Sheet1.Range(Cells(1, 1), Cells(rowCount, colCount)).AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=Sheet1.Range("ZZ2:ZZ3"), _ CopyToRange:=Range("Paste"), _ Unique:=False 獲取了資料來源、篩選條件，現在就差貼上到的新工作表了。 2、新建工作表 新建工作表的程式碼很簡單： Sheets.Add Add([Before], [After], [Count], [Type])方法的4個可選引數分別代表：在指定工作表之前新建、在指定工作表之後新建、新建工作表數量、新建工作表型別。 一般我們把總表放在第一個，會用： Sheets.Add after:=Sheet1 ActiveSheet.Name = critValue 工作表新建後會自動啟用，所以我們可以用ActiveSheet.Name給新建工作表重新命名。需要注意的是，工作表的名稱不能重複，不能超過31個字元，也不能包含一些特殊字元。這裡提供一個清除字串中特殊字元的函式，用來保證新建工作表的名字符合要求： Function sheetNamePack(ByVal sheetName As String) As String '工作表名標準化 Dim x, i sheetNamePack = "" For i = 1 To Len(sheetName) x = Mid(sheetName, i, 1) If x <> "/" And x <> "\" And x <> "?" And x <> "*" And x <> "[" And x <> "]" And x <> ":" Then sheetNamePack = sheetNamePack & x Next i sheetNamePack = Left(sheetNamePack, 10) '為了美觀只顯示前10個字元 End Function 我們給工作表重新命名的時候使用以下程式碼就能降低出錯機率： ActiveSheet.Name = sheetNamePack(critValue) 我們把新建工作表和篩選的程式碼封裝成一個過程： Sub filterData(critValue As String) Sheets.Add after:=Sheet1 ActiveSheet.Name = sheetNamePack(critValue) Sheet1.Range("ZZ3") = critValue Sheet1.Activate ' Sheet1.UsedRange.AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=Sheet1.Range("ZZ2:ZZ3"), _ CopyToRange:=Worksheets(sheetNamePack(critValue)).Range("A1"), _ Unique:=False End Sub 這裡的篩選部分比之前多了一個讓Sheet1變成活動工作表的語句，因為新建工作表會成為活動工作表，而篩選方法必須在活動工作表中才能使用。而我們發現貼上區域並不用判定大小，只要設定從A1單元格開始貼上就可以了。 3、獲取篩選條件 我們需要按某一維度篩選，首先要獲取篩選條件的欄位，為了讓篩選操作更加簡易，我們按照活動單元格所在的列進行篩選： Dim col% col = ActiveCell.Column critTitle = Sheet1.Cells(1, col) 要將所有內容分組按工作表分開，就要獲取到該欄位的所有唯一值。這裡我們使用字典的方法來進行： Dim arr, d, i%, temp arr = Sheet1.Range(Cells(2, 1), Cells(rowCount, colCount)) Set d = CreateObject("scripting.dictionary")'建立字典 For i = 1 To UBound(arr) '初始化字典，去重+計數 If d.exists(arr(i, col)) Then d(arr(i, col)) = d(arr(i, col)) + 1 Else d(arr(i, col)) = 1 End If Next temp = d.keys '臨時變數賦值 用欄位內容作為字典的key，欄位值出現的次數作為item，這樣既把唯一值提取出來又記錄了個數。現在d這個字典的內容就和上面資料透視表的圖是一樣的了。注：這裡的arr也可以用UsedRange加Resize方法和Offset方法來獲取除標題行外的資料。 然後遍歷一下字典的資料，就得到我們想要的結果了： For i = 1 To d.Count critValue = temp(i - 1) Call filterData(critValue) Next i 最後記得把臨時單元格清空： Sheet1.Range("ZZ2:ZZ3").ClearContent 4、附加功能 增加數值篩選 通過字典計數的資料我們也可以利用起來，比如如果想要把數量多於某一臨界值的資料分表列出，就可以在建立字典前輸入一個數字： Dim num$ num = InputBox("請輸入篩選值，數量大於該數值的內容將被篩選。（輸入為空則預設為0）", "輸入數字", 0)'獲取篩選值 If StrPtr(num) = 0 Then Exit Sub'點選取消退出 If num = "" Then num = "0"'輸入為空則預設為0 If IsNumeric(num) = False Then MsgBox "請輸入數字！": Exit Sub'輸入非數字 然後在篩選前和d(temp(i - 1)做比較： If d(temp(i - 1)) >= CInt(num) Then Call filterData(critValue) 遮蔽重新整理 我們一般會在巨集的第一條語句之前加一個關閉實時重新整理的命令，在最後一條語句之後再恢復，這樣做可以優化執行速度。 Sub close_Application() '關閉重新整理功能 With Application .ScreenUpdating = False .DisplayAlerts = False .EnableEvents = False .Calculation = xlCalculationManual End With End Sub Sub open_Application() '開啟重新整理功能 With Application .ScreenUpdating = True .DisplayAlerts = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With End Sub 刪除多餘工作表 在除錯的時候會產生很多新工作表，一個個刪除很耽誤時間，在執行篩選時如果遇到錯誤我們也需要進行回滾，刪除多出的工作表。 Sub clear_Sheets(Optional sheetCount As Integer = 1) '清除工作表 Call close_Application Dim i As Integer For i = Sheets.Count To sheetCount + 1 Step -1 Sheets(i).Delete Next i Call open_Application End Sub 利用Excel+VBA進行工作表的拆分大致就是這樣的過程， 整體程式碼放在附錄中，僅供參考。 附錄：程式碼部分 Sub data_Partition;() Call close_Application '獲取篩選數值 Dim num$ num = InputBox("請輸入篩選值，數量大於該數值的內容將被篩選。（輸入為空則預設為0）", "輸入數字", 0)'獲取篩選值 If StrPtr(num) = 0 Then Exit Sub'點選取消退出 If num = "" Then num = "0"'輸入為空則預設為0 If IsNumeric(num) = False Then MsgBox "請輸入數字！": Exit Sub'輸入非數字 '獲取篩選條件 Dim critTitle$, critValue$, col% col = ActiveCell.Column critTitle = Sheet1.Cells(1, col) Sheet1.Range("ZZ2") = critTitle Dim rowCount%, colCount% colCount = Sheet1.Range("XFD1").End(xlToLeft).Column rowCount = Sheet1.Range("A1048576").End(xlUp).Row '字典功能去重+計數 Dim arr, d, i%, temp arr = Sheet1.Range(Cells(2, 1), Cells(rowCount, colCount)) Set d = CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr) If d.exists(arr(i, col)) Then d(arr(i, col)) = d(arr(i, col)) + 1 Else d(arr(i, col)) = 1 End If Next temp = d.keys '遍歷字典 For i = 1 To d.Count critValue = temp(i - 1) '新建工作表並篩選 If d(temp(i - 1)) >= CInt(num) Then Call filterData(critValue) Next i Sheet1.Range("zz2:zz3").ClearContents Call open_Application End Sub Function sheetNamePack(ByVal sheetName As String) As String '工作表名標準化 Dim x, i sheetNamePack = "" For i = 1 To Len(sheetName) x = Mid(sheetName, i, 1) If x <> "/" And x <> "\" And x <> "?" And x <> "*" And x <> "[" And x <> "]" And x <> ":" Then sheetNamePack = sheetNamePack & x Next i sheetNamePack = Left(sheetNamePack, 20) End Function Sub filterData(critValue As String) Sheets.Add after:=Sheet1 ActiveSheet.Name = sheetNamePack(critValue) Sheet1.Range("ZZ3") = critValue Sheet1.Activate Sheet1.UsedRange.AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=Sheet1.Range("ZZ2:ZZ3"), _ CopyToRange:=Worksheets(sheetNamePack(critValue)).Range("A1"), _ Unique:=False End Sub Sub close_Application() '關閉重新整理功能 With Application .ScreenUpdating = False .DisplayAlerts = False .EnableEvents = False .Calculation = xlCalculationManual End With End Sub Sub open_Application() '開啟重新整理功能 With Application .ScreenUpdating = True .DisplayAlerts = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With End Sub