吳老師教學部落格(痞客邦分站)

Sub 批次篩選業務()

'關閉畫面更新

   Application.ScreenUpdating = False

   Sheets(1).Select

   Call 批次刪除工作表

    For i = 2 To Sheets("清單").Range("A2").End(xlDown).Row

        X = Sheets("清單").Cells(i, "A")

        '1.游標放B1

        Range("B1").Select

        '2.篩選

        Selection.AutoFilter

        ActiveSheet.Range("$A$1:$L$2500").AutoFilter Field:=3, Criteria1:=X

        '3.複製

        Range("A1").Select

        Range(Selection, Selection.End(xlToRight)).Select

        Range(Selection, Selection.End(xlDown)).Select

        Selection.Copy

        '4.新增工作表

        Sheets.Add After:=Sheets(Sheets.Count)

        Sheets(Sheets.Count).Name = X

        '5.貼上

        Range("A1").Select

        ActiveSheet.Paste

        '6.自動調整欄寬

        Selection.Columns.AutoFit

        Range("A1").Select

        '7.切回原工作表

        Sheets(1).Select

        Application.CutCopyMode = False

        '8.取消篩選

        Selection.AutoFilter       

        Range("A1").Select

    Next

 Application.ScreenUpdating = True

End Sub

Public Sub 移除重複()

   '排序

   Range("A1").CurrentRegion.Select

   '遞增xlAscending或1、遞減xlDescending或2

   Selection.Sort Key1:=Range("A1"), Order1:=1, Header:=xlYes

   r = Range("A1").End(xlDown).Row

   For i = r To 2 Step -1

       'Cells(i, "A").Select

       If Cells(i, "A") = Cells(i - 1, "A") Then

           Rows(i - 1).Delete

       End If

   Next

End Sub

Sub 批次篩選(清單 As String, 欄位 As Integer)

   'On Error Resume Next

   Application.ScreenUpdating = False

   Call 批次刪除工作表

   r = Sheets("清單").Range(清單 & "2").End(xlDown).Row

   For i = 2 To r

       Application.StatusBar = "目前進度：總共筆數：" & r - 1 & " 進行筆數：" & i - 1

       X = Sheets("清單").Cells(i, 清單)

       '1.游標放B1

       Range("B1").Select

       '2.篩選

       Selection.AutoFilter

       ActiveSheet.Range("$A$1:$L$2500").AutoFilter Field:=欄位, Criteria1:=X

       '3.複製

       Range("A1").Select

       Range(Selection, Selection.End(xlToRight)).Select

       Range(Selection, Selection.End(xlDown)).Select

       Selection.Copy

       '4.新增工作表

       Sheets.Add After:=Sheets(Sheets.Count)

       Sheets(Sheets.Count).Name = X

       '5.貼上

       Range("A1").Select

       ActiveSheet.Paste

       '6.自動調整欄寬

       Selection.Columns.AutoFit

       Range("A1").Select

       '7.切回原工作表

       Sheets(1).Select

       Application.CutCopyMode = False

       '8.取消篩選

       Selection.AutoFilter

       Range("A1").Select

   Next

   Application.ScreenUpdating = True

End Sub

    Call 批次篩選("A", 3)

End Sub

    Call 批次篩選("B", 4)

End Sub

   Call 批次篩選("C", 5)

End Sub

   Call 批次篩選("D", 12)