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

debugcn 发表于 Dev

乔21

这是我在excel中使用的两张纸的示例：

表格A（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

工作表B（AZ列-每个首字母缩写词至少具有1个Loc_ID，最多可以有25个）：

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

在下面的代码中，我首先浏览一下工作表B中的首字母缩写词，为每个首字母缩写词创建一个新工作表（将其重命名为该首字母缩写词），并从工作表A中添加其位置数据。

在下面r=1，我记录了一个宏来完成我要为一个首字母缩写词及其位置执行的操作，但是对于其他首字母缩写词及其位置，我不确定如何做才能遍历“ Sheet B”来完成。与我在下面为首字母缩写词“ ABC”所做的相同的任务。

有人对此问题有解决方案吗？

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

L42

试试这个：

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

这是经过尝试和测试的。它将为每个首字母缩写词创建一个工作表，并为每个首字母缩写词添加相关的Loc_ID。
自定义函数用于获取每个首字母缩写词的过滤器，然后一次性复制它。
如有疑问，请注释掉。HTH。

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。