Question

以下是我在Excel中使用的两张表的示例：

表A（A-P列）：

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（列A-Z - 每个首字母缩写词至少有1个Loc_ID，最多可以有25个）：

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

在下面的代码中，我首先查看工作表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

Answer 1

试试这个：

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。

Answer 2

循环使用.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循环中，运行所需的次数，并更改每个单独更改的常量，以便在循环中设置变量。

如何在Excel中使用VBA循环自动过滤器？

2 个答案: