Excel+VBA常用功能（一）：工作表的拆分

為了偷懶工作中很多重複性的Excel操作都被我做成了宏，在專欄里拿出一些和大家分享，也歡迎提出相關問題我們一起來思考解決。特別個性化的案例就不拿出來說了，今天先分享一個在日常工作中可能會經常遇到的場景——工作表的拆分

一、使用數據透視表

一個Excel表往往由很多欄位組成，有時我們會通過不同的維度來分析表裡的數據，有時候我們也希望將數據按照某一維度分成多個工作表。比如下表：

是的，你沒有看錯，數據透視表確實有這麼神奇的功能！這也是數據透視表很容易被忽略的一個功能！

一個簡單的數據透視表當然沒有難度，但是怎麼讓他按城市分成不同工作表呢？其實很簡單，雙擊值欄位的單元格，這時候對應行標籤的數據就會自動被篩選出來顯示在一個新的工作表當中。比如我雙擊上圖中的26那個單元格，Excel就會變成下圖的樣子：

Excel不僅新建一個sheet把對應內容篩選複製進去，而且還給表格套用了格式，真是機智的小夥伴！

不過當數據量較大的時候這種智能的方法也有點枯燥，所以我們接下來提供一個用VBA來篩選分表的方法，不管有多少行標籤都能一次到位！

二、使用VBA

1、高級篩選

篩選並複製到新工作表的關鍵代碼如下：

Range("Database").AdvancedFilter _n Action:=xlFilterCopy, _n CriteriaRange:=Range("Criteria"), _n CopyToRange:=Range("Paste"), _n Unique:=Falsen

該代碼執行結果是將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") = critTitlenSheet1.Range("ZZ3") = critValuen

這裡為了防止干擾已有數據，把臨時數據放在了702列，從第2行開始是為了不影響UsedRange的使用。如果覺得這樣不保險也可以用以下方法來獲取最後一行和最後一列：

Dim rowCount%, colCount%ncolCount = Sheet1.Range("XFD1").End(xlToLeft).Column 獲取最後一列nrowCount = Sheet1.Range("A1048576").End(xlUp).Row 獲取最後一行n

然後用Range(Cells(1, 1), Cells(rowCount, colCount))代替UsedRange，理論上這樣是更符合邏輯的。

Sheet1.Range(Cells(1, 1), Cells(rowCount, colCount)).AdvancedFilter _n Action:=xlFilterCopy, _n CriteriaRange:=Sheet1.Range("ZZ2:ZZ3"), _n CopyToRange:=Range("Paste"), _n Unique:=Falsen

獲取了數據來源、篩選條件，現在就差粘貼到的新工作表了。

2、新建工作表

新建工作表的代碼很簡單：

Sheets.Addn

Add([Before], [After], [Count], [Type])方法的4個可選參數分別代表：在指定工作表之前新建、在指定工作表之後新建、新建工作表數量、新建工作表類型。

一般我們把總表放在第一個，會用：

Sheets.Add after:=Sheet1nActiveSheet.Name = critValuen

工作表新建後會自動激活，所以我們可以用ActiveSheet.Name給新建工作表重命名。需要注意的是，工作表的名稱不能重複，不能超過31個字元，也不能包含一些特殊字元。這裡提供一個清除字元串中特殊字元的函數，用來保證新建工作表的名字元合要求：

Function sheetNamePack(ByVal sheetName As String) As Stringn工作表名標準化nDim x, insheetNamePack = ""nFor i = 1 To Len(sheetName)n x = Mid(sheetName, i, 1)n If x <> "/" And x <> "" And x <> "?" And x <> "*" And x <> "[" And x <> "]" And x <> ":" Then sheetNamePack = sheetNamePack & xnNext insheetNamePack = Left(sheetNamePack, 10) 為了美觀只顯示前10個字元nEnd Functionn

我們給工作表重命名的時候使用以下代碼就能降低出錯幾率：

ActiveSheet.Name = sheetNamePack(critValue)n

我們把新建工作表和篩選的代碼封裝成一個過程：

Sub filterData(critValue As String)nn Sheets.Add after:=Sheet1n ActiveSheet.Name = sheetNamePack(critValue)n Sheet1.Range("ZZ3") = critValuen n Sheet1.Activate n Sheet1.UsedRange.AdvancedFilter _n Action:=xlFilterCopy, _n CriteriaRange:=Sheet1.Range("ZZ2:ZZ3"), _n CopyToRange:=Worksheets(sheetNamePack(critValue)).Range("A1"), _n Unique:=FalsennEnd Subn

這裡的篩選部分比之前多了一個讓Sheet1變成活動工作表的語句，因為新建工作表會成為活動工作表，而篩選方法必須在活動工作表中才能使用。而我們發現粘貼區域並不用判定大小，只要設置從A1單元格開始粘貼就可以了。

我們需要按某一維度篩選，首先要獲取篩選條件的欄位，為了讓篩選操作更加簡易，我們按照活動單元格所在的列進行篩選：

Dim col%ncol = ActiveCell.Column ncritTitle = Sheet1.Cells(1, col)n

要將所有內容分組按工作表分開，就要獲取到該欄位的所有唯一值。這裡我們使用字典的方法來進行：

Dim arr, d, i%, tempnarr = Sheet1.Range(Cells(2, 1), Cells(rowCount, colCount))nSet d = CreateObject("scripting.dictionary") 創建字典nFor i = 1 To UBound(arr) 初始化字典，去重+計數n If d.exists(arr(i, col)) Thenn d(arr(i, col)) = d(arr(i, col)) + 1n Elsen d(arr(i, col)) = 1n End IfnNextntemp = d.keys 臨時變數賦值n

用欄位內容作為字典的key，欄位值出現的次數作為item，這樣既把唯一值提取出來又記錄了個數。現在d這個字典的內容就和上面數據透視表的圖是一樣的了。註：這裡的arr也可以用UsedRange加Resize方法和Offset方法來獲取除標題行外的數據。

然後遍歷一下字典的數據，就得到我們想要的結果了：

For i = 1 To d.Countn critValue = temp(i - 1)n Call filterData(critValue)nNext in

最後記得把臨時單元格清空：

Sheet1.Range("ZZ2:ZZ3").ClearContentn

4、附加功能

• 增加數值篩選

通過字典計數的數據我們也可以利用起來，比如如果想要把數量多於某一臨界值的數據分表列出，就可以在創建字典前輸入一個數字：

Dim num$nnum = InputBox("請輸入篩選值，數量大於該數值的內容將被篩選。（輸入為空則默認為0）", "輸入數字", 0) 獲取篩選值nIf StrPtr(num) = 0 Then Exit Sub 點擊取消退出nIf num = "" Then num = "0" 輸入為空則默認為0nIf IsNumeric(num) = False Then MsgBox "請輸入數字！": Exit Sub 輸入非數字n

然後在篩選前和d(temp(i - 1)做比較：

If d(temp(i - 1)) >= CInt(num) Then Call filterData(critValue)n

• 屏蔽刷新

我們一般會在宏的第一條語句之前加一個關閉實時刷新的命令，在最後一條語句之後再恢復，這樣做可以優化運行速度。

Sub close_Application()n關閉刷新功能n With Applicationn .ScreenUpdating = Falsen .DisplayAlerts = Falsen .EnableEvents = Falsen .Calculation = xlCalculationManualn End WithnEnd SubnnSub open_Application()n打開刷新功能n With Applicationn .ScreenUpdating = Truen .DisplayAlerts = Truen .EnableEvents = Truen .Calculation = xlCalculationAutomaticn End WithnEnd Subn

• 刪除多餘工作表

在調試的時候會產生很多新工作表，一個個刪除很耽誤時間，在執行篩選時如果遇到錯誤我們也需要進行回滾，刪除多出的工作表。

Sub clear_Sheets(Optional sheetCount As Integer = 1)n清除工作表nCall close_ApplicationnDim i As IntegernFor i = Sheets.Count To sheetCount + 1 Step -1n Sheets(i).DeletenNext inCall open_ApplicationnEnd Subn

利用Excel+VBA進行工作表的拆分大致就是這樣的過程， 整體代碼放在附錄中，僅供參考。

附錄：代碼部分

Sub data_Partition;()nCall close_Applicationnn獲取篩選數值nDim num$nnum = InputBox("請輸入篩選值，數量大於該數值的內容將被篩選。（輸入為空則默認為0）", "輸入數字", 0) 獲取篩選值nIf StrPtr(num) = 0 Then Exit Sub 點擊取消退出nIf num = "" Then num = "0" 輸入為空則默認為0nIf IsNumeric(num) = False Then MsgBox "請輸入數字！": Exit Sub 輸入非數字nn獲取篩選條件nDim critTitle$, critValue$, col%ncol = ActiveCell.ColumnncritTitle = Sheet1.Cells(1, col)nSheet1.Range("ZZ2") = critTitlennDim rowCount%, colCount%ncolCount = Sheet1.Range("XFD1").End(xlToLeft).ColumnnrowCount = Sheet1.Range("A1048576").End(xlUp).Rownn字典功能去重+計數nDim arr, d, i%, tempnarr = Sheet1.Range(Cells(2, 1), Cells(rowCount, colCount))nSet d = CreateObject("Scripting.Dictionary")nFor i = 1 To UBound(arr)n If d.exists(arr(i, col)) Thenn d(arr(i, col)) = d(arr(i, col)) + 1n Elsen d(arr(i, col)) = 1n End IfnNextntemp = d.keysnn遍歷字典nFor i = 1 To d.Countn critValue = temp(i - 1)n 新建工作表並篩選n If d(temp(i - 1)) >= CInt(num) Then Call filterData(critValue)nNext inSheet1.Range("zz2:zz3").ClearContentsnnCall open_ApplicationnEnd SubnnFunction sheetNamePack(ByVal sheetName As String) As Stringn工作表名標準化nDim x, insheetNamePack = ""nFor i = 1 To Len(sheetName)n x = Mid(sheetName, i, 1)n If x <> "/" And x <> "" And x <> "?" And x <> "*" And x <> "[" And x <> "]" And x <> ":" Then sheetNamePack = sheetNamePack & xnNext insheetNamePack = Left(sheetNamePack, 20)nEnd FunctionnnSub filterData(critValue As String)nn Sheets.Add after:=Sheet1n ActiveSheet.Name = sheetNamePack(critValue)n Sheet1.Range("ZZ3") = critValuen n Sheet1.Activaten Sheet1.UsedRange.AdvancedFilter _n Action:=xlFilterCopy, _n CriteriaRange:=Sheet1.Range("ZZ2:ZZ3"), _n CopyToRange:=Worksheets(sheetNamePack(critValue)).Range("A1"), _n Unique:=FalsennEnd SubnnSub close_Application()n關閉刷新功能n With Applicationn .ScreenUpdating = Falsen .DisplayAlerts = Falsen .EnableEvents = Falsen .Calculation = xlCalculationManualn End With nEnd SubnnSub open_Application()n打開刷新功能n With Applicationn .ScreenUpdating = Truen .DisplayAlerts = Truen .EnableEvents = Truen .Calculation = xlCalculationAutomaticn End WithnEnd Subn

推薦閱讀：