EXCEL VBA 工作表拆分

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
本文经用户投稿或网站收集转载,如有侵权请联系本站。

发表评论

0条回复