VBA筛选和复制-较短的例程？

Posted 2023-01-05

是否有可能创建例程来缩短我在下面编写的代码？目前，正在复制相同的过程，但要重复x次。

Sub FilterandTrans()
Dim LastRow As Long

With Worksheets("Sheet1")

.Range("N:N").Replace What:="inf", Replacement:="0", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

LastRow = .Range("M" & .Rows.Count).End(xlUp).Row

.Range("$M:$M").AutoFilter
.Range("$M:$M").AutoFilter field:=1, Criteria1:="Alpha"
.Range("N2:N" & LastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=ThisWorkbook.Sheets(2).Range("a2")

'shorten below?

.Range("$M:$M").AutoFilter
.Range("$M:$M").AutoFilter field:=1, Criteria1:="Beta"
.Range("N2:N" & LastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=ThisWorkbook.Sheets(2).Range("b2")

.Range("$M:$M").AutoFilter
.Range("$M:$M").AutoFilter field:=1, Criteria1:="Delta"
.Range("N2:N" & LastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=ThisWorkbook.Sheets(2).Range("c2")

.Range("$M:$M").AutoFilter
.Range("$M:$M").AutoFilter field:=1, Criteria1:="Gamma"
.Range("N2:N" & LastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=ThisWorkbook.Sheets(2).Range("d2")

.Range("$M:$M").AutoFilter
.Range("$M:$M").AutoFilter field:=1, Criteria1:="Rho"
.Range("N2:N" & LastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=ThisWorkbook.Sheets(2).Range("e2")

.AutoFilterMode = False


End With
End Sub

答案

Sub FilterandTrans() Dim LastRow As Long With Worksheets("Sheet1") .Range("N:N").Replace What:="inf", Replacement:="0", LookAt:=xlPart, _ SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False LastRow = .Range("M" & .Rows.Count).End(xlUp).Row Dim criteriadict As Object Dim key As Variant Set criteriadict = CreateObject("Scripting.Dictionary") 'Late bound Microsoft Scripting Runtime is the reference to early bind criteriadict.Add "Alpha", "a1" criteriadict.Add "Beta", "b1" criteriadict.Add "Delta", "c1" criteriadict.Add "Gamma", "d1" criteriadict.Add "Rho", "e1" For Each key In criteriadict .Range("$M:$M").AutoFilter .Range("$M:$M").AutoFilter field:=1, Criteria1:=key 'Alpha, Beta, ... .Range("N2:N" & LastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=ThisWorkbook.Sheets(2).Range(criteriadict(key)) 'Range Value Next k .AutoFilterMode = False End With End Sub

另一答案

.Range("$M:$M").AutoFilter .Range("$M:$M").AutoFilter field:=1, Criteria1:=Array( _ "Alpha", "Beta", "Gamma", "Delta", "Rho"), Operator:=xlFilterValues .Range("N2:N" & LastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=ThisWorkbook.Sheets(2).Range("a2")