自動篩選、分類到新工作表(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
2017-05-03 6:18 #1
先謝謝 Snare大大 分享這心得文章
依功能說明來看,的確是在管理資料運用上蠻實用的一個功能,
看過編碼的部份之後,發覺有幾個指令敍述是在下目前還沒用過的,
像是 AdvancedFilter AutoFilter 這二個的用途,
只好待會先來查一下 MSDN 說明並測試一下看看,
有什麼心得的話會再來回覆..^^
限制級
您即將進入之討論頁 需滿18歲 方可瀏覽。
提醒:內容可能因過於寫實、驚悚而令人感到不舒服,是否繼續觀看?

根據「電腦網路內容分級處理辦法」修正條文第六條第三款規定,已於該限制級網頁,依台灣網站分級推廣基金會規定作標示。
評分
複製連結