自動篩選、分類到新工作表(vba範例)

這個vba範例，其實回答過幾次了，只是都在內文裡，不是發表新文章
當時寫的範例因為輸出結果是對的，就沒仔細檢查程式碼
今天突然發現，程式碼不夠簡化，有些地方寫錯，重覆計算，
所以重新整理一下，有興趣的就看看吧

測試資料總表


分類到新工作表





'===7/14，不想文章浮上去，偷偷小更新，簡化程式碼======

'======程式碼請放在模組裡==========================
'程式功能
'篩選出所有不重覆項目後，自動分類到新工作表，資料欄位數量1~最大值
'測試時，請不要輸入不存在 or 沒資料的欄位名稱，程式沒特別處理，會出錯的


Sub autofilter()

Call delsheet

Dim c As String, allcriteria
c = InputBox("請輸入英文欄位名稱，預設 a 欄", , "a")
If c = "" Then Exit Sub

Application.ScreenUpdating = False
With Sheets("sheet1")

.Range(c & ":" & c).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set allcriteria = .Range(.Cells(2, c), .Cells(2, c).End(xlDown)).SpecialCells(xlCellTypeVisible)

For Each n In allcriteria
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "_" & n & "_"
.Range(c & ":" & c).autofilter Field:=1, Criteria1:=n
.UsedRange.Copy Sheets("_" & n & "_").Cells(1, 1)
Next

.AutoFilterMode = False
End With
Application.ScreenUpdating = True

End Sub



'秒刪 sheet1以外的所有工作表，就算上百個也是瞬間秒刪
'不想用也行，刪掉Call delsheet那一行即可

Sub delsheet()

    Application.DisplayAlerts = False

    Dim delsheet() As Variant
    ReDim delsheet(1 To Worksheets.Count)

    For i = 1 To Worksheets.Count
        If Worksheets(i).Name <> "Sheet1" Then
            j = j + 1
            delsheet(j) = Worksheets(i).Name
        End If
    Next
    
    If j = "" Then Exit Sub
    
    ReDim Preserve delsheet(1 To j)
    Worksheets(delsheet).Delete

    Application.DisplayAlerts = True


End Sub

'===============================================

附加壓縮檔: 201707/mobile01-7a85102cdaa83d121a6c393fe3cc3ec6.zip