以下是我在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
答案 0 :(得分: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。
答案 1 :(得分:0)
循环使用.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循环中,运行所需的次数,并更改每个单独更改的常量,以便在循环中设置变量。