I have a filter in an excel sheet that I wish to step through I have recorded the filter part. But what I now wish to do is loop through the remaining rows and paste the row numbers into another sheet, eg "Sheet2"

I think a collection might be what I need but am not sure.

Can you please correct the code and put me on the right track

Thanks, Peter

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

CodePudding user response：

Copy the Row Numbers of Filtered Rows (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 ' ?
    ' Clear possible existing filters.
    If sws.FilterMode Then sws.ShowAllData
    
    ' 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