如何在 Excel 中使用 VBA 遍历自动过滤器？
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/25203910/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
How do I loop through an Autofilter using VBA in excel?
提问by Joe21
Here is an example of the two sheets I am working with in excel:
这是我在 excel 中使用的两张工作表的示例：
Sheet A (Columns A-P):
工作表 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
Sheet B (Columns A-Z -- each acronym has at least 1 Loc_ID and can have up to 25):
工作表 B（列 AZ - 每个首字母缩略词至少有 1 个 Loc_ID，最多可以有 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.
在下面的代码中，我首先查看工作表 B 中的首字母缩略词，为每个首字母缩略词创建一个新工作表（将其重命名为该首字母缩略词），并从工作表 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".
下面r=1，我录制了一个宏来为一个首字母缩略词及其位置执行我想要完成的操作，但是对于其他首字母缩略词及其位置，我不确定我可以做些什么来循环遍历“表 B”以完成与我在下面为首字母缩写词所做的相同的任务：“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:$P63").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:$P63").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
回答by L42
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.
这是经过试验和测试的。它将为每个首字母缩略词创建一个表并为每个首字母缩略词添加相关的 Loc_ID。
自定义函数用于获取每个首字母缩略词的过滤器，然后一次性复制它。
如果您有任何疑问，请发表评论。哈。
回答by Tom
loop through using .specialcells(xlcelltypevisible)This will only look at the filtered resuls
循环使用.specialcells(xlcelltypevisible)这只会查看过滤后的结果
Try Using This instead of recorded
尝试使用这个而不是记录
'Start each acronym at "1"'
r = 1
With Sheets("Leavers")
.Range("$A:$P63").AutoFilter Field:=1, Criteria1:="687987"
.Range("A1", Cells("A1").End(xlToRight)).SpecialCells(xlCellTypeVisible).Copy
End With
Sheets("ABX").Paste
Sheets("Leavers").Range("$A:$P63").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.
把它放在一个 for 循环中，你需要它运行的次数，并更改每张纸上会更改的每个常量，以便您可以在循环内设置一个变量。
