VBA selecting the first three rows after filtering-CodePudding

The code below in VBA applies filter to a certain table, select the visible cells after the filter and then paste the content in another tab called "CICLICO". The problem is... I want only the first three items AFTER applying the filter. Any ideas?

Sub Select_TheFirstThreeItemsAfterFilter()
'
    Range("P8").Select 
    ActiveSheet.ListObjects("Tabela1").Range.AutoFilter Field:=10, Criteria1:= _
        "MONTAGEM A"
    ActiveSheet.ListObjects("Tabela1").Range.AutoFilter Field:=7, Criteria1:= _
        "A"
    ActiveSheet.ListObjects("Tabela1").Range.AutoFilter Field:=4, Criteria1:= _
        Array("100", "110", "1159", "118", "119", "120", "135", "139", "14", "144", "152", "16", _
        "161", "163", "171", "19", "209", "21", "212", "240", "25", "251", "280", "285", "3", "31", _
        "32", "34", "36", "381", "39", "390", "5", "51", "54", "63", "67", "70", "74", "8", "84", "94" _
        , "97"), Operator:=xlFilterValues
    ActiveSheet.ListObjects("Tabela1").Range.AutoFilter Field:=14, Criteria1:= _
        "="
        
    Range("B11:H400").Select 'here is the part I want to select only the First Three Items After the filter
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
     
    Sheets("CICLICO").Select 'this select another tab and paste the information after the filter
    Range("B8").Select
    ActiveSheet.Paste

   
End Sub

I know I have to use the "Selection.SpecialCells(xlCellTypeVisible).Select" But I don't know how the select the first three items considering the number of the rows always change... But I don't know how to select the first three rows after applying the filter.

For example: Sometimes I want to select the rows 233, 500, 800 and another times 900, 1200 and 1800.

CodePudding user response：

Use .Resize to define how large a range you're selecting/copying.

Sub Select_TheFirstThreeItemsAfterFilter()

    Range("P8").Select 
    ActiveSheet.ListObjects("Tabela1").Range.AutoFilter Field:=10, Criteria1:= _
        "MONTAGEM A"
    ActiveSheet.ListObjects("Tabela1").Range.AutoFilter Field:=7, Criteria1:= _
        "A"
    ActiveSheet.ListObjects("Tabela1").Range.AutoFilter Field:=4, Criteria1:= _
        Array("100", "110", "1159", "118", "119", "120", "135", "139", "14", "144", "152", "16", _
        "161", "163", "171", "19", "209", "21", "212", "240", "25", "251", "280", "285", "3", "31", _
        "32", "34", "36", "381", "39", "390", "5", "51", "54", "63", "67", "70", "74", "8", "84", "94" _
        , "97"), Operator:=xlFilterValues
    ActiveSheet.ListObjects("Tabela1").Range.AutoFilter Field:=14, Criteria1:= _
        "="
        
    Range("B11:H400").SpecialCells(xlCellTypeVisible).Resize(3).Copy _
    Destination:= Sheets("CICLICO").Range("B8")

End Sub

Note that the entire select/copy/paste action was done in (effectively) a single line of code - it's good practice to avoid using select wherever possible.

CodePudding user response：

Copy Specified Number of Rows From Discontinuous Range

Sub CopyThreeFilteredRows()

    Const ROWS_COUNT As Long = 3

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim sws As Worksheet: Set sws = wb.Sheets("Unknown") ' adjust!
    Dim lo As ListObject: Set lo = sws.ListObjects("Tabela1")
    
    With lo
        If .ShowAutoFilter Then
            If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
        End If
        With .Range
            .AutoFilter Field:=10, Criteria1:="MONTAGEM A"
            .AutoFilter Field:=7, Criteria1:="A"
            .AutoFilter Field:=4, Criteria1:=Array( _
                "100", "110", "1159", "118", "119", "120", "135", "139", _
                "14", "144", "152", "16", "161", "163", "171", "19", _
                "209", "21", "212", "240", "25", "251", "280", "285", _
                "3", "31", "32", "34", "36", "381", "39", "390", _
                "5", "51", "54", "63", "67", "70", "74", "8", _
                "84", "94", "97"), Operator:=xlFilterValues
            .AutoFilter Field:=14, Criteria1:="="
        End With
        Dim vrg As Range ' visible rows
        On Error Resume Next
            Set vrg = .DataBodyRange.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        .AutoFilter.ShowAllData
    End With
        
    If vrg Is Nothing Then Exit Sub
        
    Dim srg As Range: Set srg = Intersect(vrg, sws.Columns("B:H"))
    ' The previous is inappropriate. The following would be better...
    'Set srg = Intersect(vrg, lo.DataBodyRange.Columns(2).Resize(, 7))
    ' ... so you could freely move the table around.
    
    Dim ColumnsCount As Long: ColumnsCount = srg.Columns.Count
    
    Dim scrg As Range, srrg As Range, r As Long
    
    For Each srrg In srg.Rows
        r = r   1
        If scrg Is Nothing Then
            Set scrg = srrg
        Else
            Set scrg = Union(scrg, srrg)
        End If
        If r >= ROWS_COUNT Then Exit For
    Next srrg
    
    Dim dws As Worksheet: Set dws = wb.Sheets("CICLICO")
    Dim dfCell As Range: Set dfCell = dws.Range("B8")
    dfCell.Resize(ROWS_COUNT, ColumnsCount).Clear
    
    scrg.Copy dfCell
   
End Sub