从自动筛选器中筛选行

Question

我在excel工作表中有一个过滤器，我希望逐步通过我已经记录了过滤部分。但我现在想做的是循环遍历剩下的行，并将行号粘贴到另一个工作表中，例如"Sheet2">

我想一个集合可能是我需要的，但我不确定。

你能把代码纠正一下，让我走上正确的轨道吗

谢谢你,彼得

Sub FilterBOQ()
'
Dim rng As Range
Sheets("BOQ").Select
ActiveSheet.Outline.ShowLevels RowLevels:=2
ActiveSheet.ShowAllData
ActiveSheet.Range("$A$3:$S$2219").AutoFilter Field:=2, Criteria1:="110"
ActiveSheet.Range("$A$3:$S$2219").AutoFilter Field:=11, Criteria1:="<>0"
End Sub

Answer 1

复制已过滤行(AutoFilter)的行号

Option Explicit
Sub FilterBOQ()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code

' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets("BOQ")
' ...
sws.Outline.ShowLevels RowLevels:=2 ' ?
' Turn off AutoFilter.
If sws.AutoFilterMode Then sws.AutoFilterMode = False

' Reference the source range ('srg') (has headers).
Dim srg As Range: Set srg = sws.Range("A3:S2219")
' Reference the source data range ('sdrg') (no headers).
Dim sdrg As Range: Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)

' Autofilter the source range.
srg.AutoFilter Field:=2, Criteria1:="110"
srg.AutoFilter Field:=11, Criteria1:="<>0"

' Attempt to reference the (probably non-contiguous) filtered column range
' ('fcrg'), the intersection of the filtered rows of the source data range
' and the first (can be any) column of the source data range.
Dim fcrg As Range
On Error Resume Next
Set fcrg = Intersect( _
sdrg.SpecialCells(xlCellTypeVisible), sdrg.Columns(1))
On Error GoTo 0

' Turn off the autofilter.
sws.AutoFilterMode = False

' Validate the filtered column range. Inform and exit if 'Nothing'.
If fcrg Is Nothing Then
MsgBox "Found no filtered rows.", vbExclamation
Exit Sub
End If

' Using the number of cells in the filtered column range,
' define a 2D one-based one-column array, the destination array ('dData').
Dim dData() As Variant: ReDim dData(1 To fcrg.Cells.Count, 1 To 1)

' Declare additional variables to be used in the loop. 
Dim sCell As Range ' Current Cell of the Filtered Column Range
Dim dr As Long ' Current Destination Array Row

' Loop through the cells of the filtered column range.
For Each sCell In fcrg.Cells
dr = dr + 1 ' next destination array row
dData(dr, 1) = sCell.Row ' write the row number
Next sCell

' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet2")
' Reference the destination first cell ('dfCell').
Dim dfCell As Range: Set dfCell = dws.Range("A2")
' Reference the destination (one-column) range ('drg').
Dim drg As Range: Set drg = dfCell.Resize(dr)

' Write the values from the destination array to the destination range.
drg.Value = dData
' Clear below.
drg.Resize(dws.Rows.Count - drg.Row - dr + 1).Offset(dr).Clear

' Inform to not wonder if the code has run or not.
MsgBox dr & " row numbers copied.", vbInformation
End Sub