如何在Excel中使用VBA遍历自动筛选器？

Question

Here is an example of the two sheets I am working with in excel:

Sheet A (Columns AP):

Loc_ID     Loc_Name        First     Last     ...   ...   ...
123456     ABXC - Sales    John      Smith
123456     ABXC - Sales    Joe       Smith
123456     ABXC - Sales    Larry     Smith
123456     ABXC - Sales    Carolyn   Smith
654321     ABXC - Sales    Laura     Smith
654321     ABXC - Sales    Amy       Smtih

Sheet B (Columns AZ -- each acronym has at least 1 Loc_ID and can have up to 25):

ABC     CBA     AAU     ...   ...   ...  ...
123456  423656  123578
654321  656324  875321
        123987  108932
                ...

In the code below, I am first looking through the acronyms in Sheet B to create a new sheet for each acronym (rename it as that acronym) and add it's locations data from Sheet A.

Below r=1 , I have a recorded a Macro to do what I want to accomplish for one acronym and it's locations, but for the other acronyms and its locations, I'm not sure what I can do to loop through "Sheet B" to accomplish the same task as I have done below for the acronym: "ABC".

Anyone have a solution to this problem?

Sub Macro5()
       Dim shtA As Worksheet     'variable represents Leavers'
       Dim shtB As Worksheet     'variable represents Tables'
       Dim shtNew As Worksheet   'variable to hold the "new" sheet for each acronym'
       Dim acronyms As Range     'range to define the list of acronyms'
       Dim cl As Range           'cell iterator for each acronmym'
       Dim r As Integer          'iterator, counts the number of locations in each acronym'
       Dim valueToFind As String 'holds the location that we're trying to Find'
       Dim foundRange As Range   'the result of the .Find() method'
       Dim MyRange As Range


'Assign our worksheets variables'
       Set shtA = Worksheets("Leavers")
       Set shtB = Worksheets("Tables")

'Assign the list of acronmys in "Tables"'
       Set acronyms = shtB.Range("B1:Z1")

'Loop over each DIV code:'
       For Each cl In acronyms.Cells
'Add new sheet for each acronym:'
       Set shtNew = Sheets.Add(After:=Sheets(Sheets.Count))
       shtNew.Name = cl.Value

'Start each acronym at "1"'
       r = 1

Sheets("Tables").Select
Range("B2").Select
Selection.Copy
Sheets("Leavers").Select
ActiveSheet.Range("$A$1:$P$6463").AutoFilter Field:=1, Criteria1:="687987"
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("ABX").Select
ActiveSheet.Paste
Sheets("Tables").Select
Range("B3").Select
Selection.Copy
Sheets("Leavers").Select
ActiveSheet.Range("$A$1:$P$6463").AutoFilter Field:=1, Criteria1:="004740"
ActiveCell.Offset(1, 0).Select
With ActiveSheet.UsedRange
Set MyRange = Range(.Cells(2, 1), .Cells(1, 1).Offset(.Rows.Count - 1, .Columns.Count - 1))
MyRange.Select
End With
Selection.Copy
Sheets("ABX").Select
Range("A2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Next

End Sub

Answer 1

Try this:

Sub ject()
    Dim acronym As Range, cl As Range, idr As Range
    Dim LocIDFilter, nws As Worksheet
    Dim ws1 As Worksheet: Set ws1 = Sheet1 '~~> change to suit
    Dim ws2 As Worksheet: Set ws2 = Sheet2 '~~> change to suit
    Dim datarange As Range

    With ws1
        Set datarange = .Range("A1", .Range("P" & .Rows.Count).End(xlUp))
    End With

    Set acronym = ws2.Range("B1:Z1")
    For Each cl In acronym
        Set idr = cl.Resize(cl.Range("A" & ws2.Rows.Count).End(xlUp).Row)
        LocIDFilter = GetFilters(idr)
        Set nws = ThisWorkbook.Sheets.Add(after:= _
            ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        nws.Name = cl.Value
        datarange.AutoFilter 1, LocIDFilter, xlFilterValues
        datarange.SpecialCells(xlCellTypeVisible).Copy nws.Range("A1")
    Next
    ws1.AutoFilterMode = False
End Sub

---

Private Function GetFilters(source As Range)
    Dim c As Range
    If Not source Is Nothing Then
        With CreateObject("Scripting.Dictionary")
            For Each c In source.SpecialCells(xlCellTypeVisible).Cells
                If Not .Exists(CStr(c.Value)) Then .Add CStr(c.Value), CStr(c.Value)
            Next
            GetFilters = .Keys
        End With
    End If
End Function

This is tried and tested. It will create a sheet for each acronym and add relevant Loc_ID for each.
A custom function is used to get the filters for each acronym and then copy it in one go.
If you have questions, comment it out. HTH.

Answer 2

loop through using .specialcells(xlcelltypevisible) This will only look at the filtered resuls

Try Using This instead of recorded

'Start each acronym at "1"'
r = 1

With Sheets("Leavers")
    .Range("$A$1:$P$6463").AutoFilter Field:=1, Criteria1:="687987"
    .Range("A1", Cells("A1").End(xlToRight)).SpecialCells(xlCellTypeVisible).Copy
End With
Sheets("ABX").Paste
Sheets("Leavers").Range("$A$1:$P$6463").AutoFilter Field:=1, Criteria1:="004740"
With Sheets("Leaver").UsedRange
    Set MyRange = Range(.Cells(2, 1), .Cells(1, 1).Offset(.Rows.Count - 1, .Columns.Count - 1))
    MyRange.Copy
End With
Sheets("ABX").Range("A2", Cells("A2").End(xlDown)).Paste

Put this inside a for loop for the number of times you need it to run, and change each constant that would change per sheet for a variable which you can set inside the loop.