逐步浏览我的自动过滤器中的行

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