如何在excel中使用VBA循环自动筛选？

以下是我在excel中使用的两张工作表的示例：

表A（A-p列）：

表B（A-Z列——每个首字母缩写词至少有一个Loc_ID，最多可以有25个）：

在下面的代码中，我首先查看表B中的首字母缩略词，为每个首字母缩略词创建一个新表（将其重命名为该首字母缩略词），并从表a中添加其位置数据

在

r=1

下面，我记录了一个宏来完成我想要完成的一个首字母缩略词及其位置，但对于其他首字母缩略词及其位置，我不确定我能做些什么来循环通过“表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

---

使用

.specialcells（xlcelltypevisible）

进行循环，这将只查看过滤后的结果

尝试使用此文件而不是录制的文件

'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

将其放入for循环中，以获得运行所需的次数，并更改每一页中可在循环中设置的变量的每个常数。

尝试以下操作：

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

---

这是经过考验的。它将为每个首字母缩写创建一张表格，并为每个首字母缩写添加相关的Loc_ID。
自定义函数用于获取每个首字母缩略词的过滤器，然后一次性复制。

---

如果你有问题，请评论出来。HTH.

我应该在哪里添加？在

r=1

之后，我需要更改我的代码，我很确定我已经稍微更新了我的答案-尝试一下，它未经测试，所以您可能希望第一次进行测试。应该运行得更快，而不是选择单元格。我收到一个运行时错误“5”->在您有

.specialcells（xlcelltypevisible）的地方出现无效的过程调用或参数。复制
对此有什么想法吗？我将返回我的第一个答案-以
.specialcells（xlcelltypevisible）
为例，然后我将得到相同的错误。我不知道该怎么办。不过，我很感谢你的帮助，好极了！非常感谢你的帮助。
'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

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