如何遍历VBA中的所有过滤器选项?

Question

我想使用循环来遍历过滤器中的每个条件，然后计算并输出平均值。我下面的代码计算平均值并将其输出到第二个工作表的下一个空行上，但不幸的是，这仅适用于第一个过滤器选择。在循环的每次新迭代之后，什么都不会发生。谁能帮忙？

源数据 输出

Option Explicit
Sub avg()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim cell As Range
Dim lastrow As Long
Dim RowCount As Long
Dim rng1 As Range
Dim nextrow As Long

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
lastrow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
RowCount = ws2.Cells(Rows.Count, 1).End(xlUp).Row

Set rng1 = ws1.Range("G2:G" & lastrow)
For Each cell In rng1.SpecialCells(xlCellTypeVisible)
With ws1.AutoFilter.Range
ws2.Range("A" & RowCount + 1) = ws1.Range("B" & .Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value2
ws2.Range("B" & RowCount + 1) = ws1.Range("F" & .Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value2
End With
ws2.Range("C" & RowCount + 1) = Application.WorksheetFunction.Average(ws1.Range("Y2:Y" & lastrow & ",Z2:Z" & lastrow & ",AA2:AA" & lastrow _
& ",AD2:AD" & lastrow & ",AE2:AE" & lastrow & ",AI2:AI" & lastrow & ",AK2:AK" & lastrow & ",AL2:AL" & lastrow).SpecialCells(xlCellTypeVisible))
ws2.Range("D" & RowCount + 1) = Application.WorksheetFunction.Average(ws1.Range("AF2:AF" & lastrow & ",AM2:AM" & lastrow & ",AP2:AP" & lastrow _
& ",AQ2:AQ" & lastrow & ",AR2:AR" & lastrow & ",AS2:AS" & lastrow & ",AT2:AT" & lastrow & ",AU2:AU" & lastrow).SpecialCells(xlCellTypeVisible))
ws2.Range("E" & RowCount + 1) = Application.WorksheetFunction.Average(ws1.Range("AW2:AW" & lastrow & ",AX2:AX" & lastrow & ",AY2:AY" & lastrow).SpecialCells(xlCellTypeVisible))
Next cell
End Sub

Answer 1

宏中所做的更改很少。请注意，新添加的数组用于筛选条件的唯一值，循环从每个单元格更改为数组。lastrow和RowCount变量替换为lastrow1和lastrow2。

Sub avg()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cell As Range, rng1 As Range, rng1Crt As Range
Dim lastrow1 As Long, lastrow2 As Long, arr As Variant
Set ws1 = wb.Worksheets("Sheet1")
Set ws2 = wb.Worksheets("Sheet2")
lastrow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng1 = ws1.Range("G1:G" & lastrow1)
rng1.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rng1Crt = rng1.Cells.SpecialCells(xlCellTypeVisible)
'Populating array with filter criteria values
ReDim arr(0 To rng1Crt.Cells.Count - 1)
i = 0
For Each cell In rng1Crt.Cells
arr(i) = cell.Value
i = i + 1
Next
ws1.ShowAllData
rng1.AutoFilter
For i = 1 To UBound(arr)
lastrow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
rng1.AutoFilter Field:=1, Criteria1:=arr(i)
With ws1.AutoFilter.Range
ws2.Range("A" & lastrow2 + 1) = ws1.Range("B" & .Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value2
ws2.Range("B" & lastrow2 + 1) = ws1.Range("F" & .Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value2
End With
ws2.Range("C" & lastrow2 + 1) = Application.WorksheetFunction.Average(ws1.Range("Y2:Y" & lastrow1 & ",Z2:Z" & lastrow1 & ",AA2:AA" & lastrow1 _
& ",AD2:AD" & lastrow1 & ",AE2:AE" & lastrow1 & ",AI2:AI" & lastrow1 & ",AK2:AK" & lastrow1 & ",AL2:AL" & lastrow1).SpecialCells(xlCellTypeVisible))
ws2.Range("D" & lastrow2 + 1) = Application.WorksheetFunction.Average(ws1.Range("AF2:AF" & lastrow1 & ",AM2:AM" & lastrow1 & ",AP2:AP" & lastrow1 _
& ",AQ2:AQ" & lastrow1 & ",AR2:AR" & lastrow1 & ",AS2:AS" & lastrow1 & ",AT2:AT" & lastrow1 & ",AU2:AU" & lastrow1).SpecialCells(xlCellTypeVisible))
ws2.Range("E" & lastrow2 + 1) = Application.WorksheetFunction.Average(ws1.Range("AW2:AW" & lastrow1 & ",AX2:AX" & lastrow1 & ",AY2:AY" & lastrow1).SpecialCells(xlCellTypeVisible))
Next
End Sub