Copy last x values from a filtered range-CodePudding

I am using AutoFilter to reduce a range of data, based on specific criteria. Once the filter is applied, I could have anything between 100 rows to 1000 rows. I know before the filter has run that I will want to copy a specific number of rows from this filtered list - often this is a small number e.g. 3, 4 or 5. I store this number in a variable called SELECTIONS. What I'm struggling to achieve is copying this number of rows from the filtered data. I've tried various approaches but none of them seem to allow me to copy the rows I want.

Here's my code below:

'Define how many selections are required
Dim selections As Integer
selections = Sheets("MO Systems").Range("Q2").Value

Dim LastRow, SelectRow As Long

'Defines sheet and row where we will paste data
SelectRow = Sheets("Selections").Range("A165536").End(xlUp).Row   1

'Remove any autofilter than had previously been applied
Sheets("Overs Assessment").Select
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If

'Apply Filters
'Filter 1
Sheets("Overs Assessment").Range("$A$1:$FW$50881").AutoFilter Field:=3, Criteria1:=">1.0"
'Filter 2
Sheets("Overs Assessment").Range("$A$1:$FW$50881").AutoFilter Field:=50, Criteria1:=">=3.9", Operator:=xlAnd, Criteria2:="<=7"
'Filter 3
Sheets("Overs Assessment").Range("$A$1:$FW$50881").AutoFilter Field:=37, Criteria1:=">1.79", Operator:=xlAnd
'Filter 4
Sheets("Overs Assessment").Range("$A$1:$FW$50881").AutoFilter Field:=58, Criteria1:=">=4.54", Operator:=xlAnd, Criteria2:="<=11.99"
'Date Filter
Sheets("Overs Assessment").Range("$A$1:$FW$50881").AutoFilter Field:=1, Criteria1:=Sheets("MO Systems").Range("F2").Value

'If there is only one selection, I can copy the lastrow and this is simple
If selections = 1 Then
LastRow = Sheets("Overs Assessment").Cells(1, 1).SpecialCells(xlCellTypeVisible).End(xlDown).Row
Sheets("Overs Assessment").Range("A" & LastRow & ":E" & LastRow).Copy
Sheets("Selections").Range("A" & SelectRow).PasteSpecial xlValues
Else
'If selections > 1, this is where I cannot seem to find a solution to copy the relevant cells.
End If

CodePudding user response：

Iterate backwards through the areas and rows of the non-contigous filtered range and fill an array with row numbers.

Option Explicit

Sub CopyEnd()

    'Define how many selections are required
    Dim selections As Integer
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim rngFilter As Range, rngCopy
    Dim LastRow As Long, destRow As Long
    
    selections = Sheets("MO Systems").Range("Q2").Value
    
    'Defines sheet and row where we will paste data
    Set wsDest = Sheets("Selections")
    With wsDest
        destRow = .Cells(.Rows.Count, 1).End(xlUp).Row   1
    End With
    
    Set wsSrc = Sheets("Overs Assessment")
    With wsSrc
        ' set filter range
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set rngFilter = .Range("A1:V" & LastRow)
        
        'Remove any autofilter than had previously been applied
        If (.AutoFilterMode And .FilterMode) Or .FilterMode Then
            .ShowAllData
        End If

        'Apply Filters
        With rngFilter
            'Filter 1,3,3,4,Date
            .AutoFilter
            .AutoFilter Field:=3, Criteria1:=">1.0"
            .AutoFilter Field:=50, Criteria1:=">=3.9", Operator:=xlAnd, Criteria2:="<=7"
            .AutoFilter Field:=37, Criteria1:=">1.79"
            .AutoFilter Field:=58, Criteria1:=">=4.54", Operator:=xlAnd, Criteria2:="<=11.99"
            .AutoFilter Field:=1, Criteria1:=Sheets("MO Systems").Range("F2").Value
            ' rng to copy
            Set rngCopy = .SpecialCells(xlCellTypeVisible)
            MsgBox "Filter Range is " & rngCopy.Address
            
            '.AutoFilter ' remove filters
        End With
          
        ' fill array with row numbers of last n rows
        Dim i As Long, k As Long, n As Long, a, r, ar
        n = selections
        ReDim ar(1 To n)
        For a = rngCopy.Areas.Count To 1 Step -1
            If i = n Then Exit For
            For r = rngCopy.Areas(a).Rows.Count To 1 Step -1
                If a > 1 Or r > 1 Then ' exclude header
                    i = i   1
                    ar(i) = rngCopy.Areas(a).Rows(r).Row
                End If
                If i = n Then Exit For
            Next
        Next
        
        ' copy rows
        MsgBox i & " rows " & Join(ar, ":")
        For k = i To 1 Step -1
            wsDest.Cells(destRow, 1).Resize(, 5).Value2 = .Cells(ar(k), 1).Resize(, 5).Value2
            destRow = destRow   1
        Next
        
    End With
    MsgBox "Done"  
End Sub

CodePudding user response：

One way... (adjust ranges and sheets to suit)

Sub test()
Dim selections As Long
Dim cntRows As Long, i As Long, iRow As Long, iArea As Long
Dim rngFilter As Range
Dim rngSource As Range
Dim rngDest As Range
Dim rArea As Range

    selections = 10
    
    Set rngFilter = Worksheets("Sheet1").Range("A2:B11")  ' ("A2:FW50881")
    
    Set rngSource = rngFilter.SpecialCells(xlCellTypeVisible) ' probably a multi area range

    For Each rArea In rngSource.Areas
        cntRows = cntRows   rArea.Rows.Count ' count filtered rows
    Next
    
    If cntRows < selections Then selections = cntRows '
    
    Set rngDest = Worksheets("Sheet2").Range("A1:B" & selections)
    i = selections
    
    For iArea = rngSource.Areas.Count To 1 Step -1
        Set rArea = rngSource.Areas(iArea)
        For iRow = rArea.Rows.Count To 1 Step -1
            rngDest.Rows(i).Value = rArea.Rows(iRow).Value ' if need row formats copy/paste
            i = i - 1
            If i = 0 Then Exit For
        Next
        If i = 0 Then Exit For
    Next

End Sub

If contiguous rows are likely in the filtered range quicker to copy relevant areas, a bit more house keeping though.

CodePudding user response：

One more approach: add all of the visible cells in ColA to a Collection, then use that collection to select the rows to copy.

Sub Tester()
    
    Dim wsOvers As Worksheet, c As Range
    Dim selections As Long '<<<< always prefer Long to Integer
    Dim LastRow As Long, PasteCell As Range, rngVis As Range, n As Long
    Dim col As New Collection, i As Long
    
    selections = Sheets("MO Systems").Range("Q2").Value
    
    Set PasteCell = Sheets("Selections").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
    
    Set wsOvers = Sheets("Overs Assessment")
    
    With wsOvers
        If (.AutoFilterMode And .FilterMode) Or .FilterMode Then .ShowAllData
        With .Range("$A$1:$FW$50881")
            .AutoFilter Field:=3, Criteria1:=">1.0"
            .AutoFilter Field:=50, Criteria1:=">=3.9", Operator:=xlAnd, Criteria2:="<=7"
            .AutoFilter Field:=37, Criteria1:=">1.79", Operator:=xlAnd
            .AutoFilter Field:=58, Criteria1:=">=4.54", Operator:=xlAnd, Criteria2:="<=11.99"
            .AutoFilter Field:=1, Criteria1:=Sheets("MO Systems").Range("F2").Value
            Set rngVis = .SpecialCells(xlCellTypeVisible)
        End With
    End With
     
    n = 0
    For Each c In rngVis.Columns(1).Cells 'loop over all visible cells in ColA
        n = n   1                         '  and add them to a collection
        If n > 1 Then col.Add c           '...skipping the header
    Next c
    
    'now copy the selected last # of rows
    For n = 1 To selections
        i = col.Count - (n - 1)  'collection index
        If i < 1 Then Exit For   'not enough items in the collection
        PasteCell.Resize(1, 5).Value = col(i).Resize(1, 5).Value
        Set PasteCell = PasteCell.Offset(1) 'next row down
    Next n
    
End Sub