Copy the result of a filter from 2nd line

Question

I need to create a macro to make a filter, copy the result of that filter from the 2nd line and paste it into another sheet. I've tried everything (offset, usedrange, sendkeys) but nothing worked. I need it to be variable because the range position will change whenever I update the base with new information. This is the last code I tried:

ActiveSheet.ShowAllData
ActiveSheet.Range("$A$1:$U$419655").AutoFilter Field:=18, Criteria1:="1"
ActiveSheet.UsedRange.Offset(1, 0).Select
Selection.Copy
Sheets("HEX Acima").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks \_
:=False, Transpose:=False```

Answer 1

• ActiveSheet.ShowAllData raises error 1004 if there isn't filtering on sheet. Use If clauses to avoid the error.
• Utilize the CurrentRegion property to capture the data table if it is a contiguous range.

Microsoft documentation:

Range.CurrentRegion property (Excel)

Range.Resize property (Excel)

Option Explicit
Sub CopyAfterFilter()
    Dim visRng As Range
    If ActiveSheet.AutoFilterMode Then
        If ActiveSheet.AutoFilter.FilterMode Then
            ActiveSheet.ShowAllData
        End If
    End If
    With ActiveSheet.Range("A1").CurrentRegion
        If .Columns.Count < 18 Then Exit Sub
        .AutoFilter Field:=18, Criteria1:="1"
        Set visRng = .Resize(.Rows.Count - 1).Offset(1, 0)
        If Not visRng Is Nothing Then
            visRng.Copy
            Sheets("HEX Acima").Range("A2").PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
        End If
    End With
End Sub

Answer 2

Copy Filtered Values

Before

After

• It took about 20 s to copy about 250k 'matching' (out of 500k) rows on my more than a decade-old machine running Windows 10 64-bit and MS365 64-bit. For the same job, a solution that would sort the data to have a single area to copy, took more than 60 s using PasteSpecial and more than 80 s to copy by assignment.
• It took about another 15 s to save the file.
• Your feedback on the matter is expected.

Sub CopyFilteredValues()
    
    ' Start measuring the time passed.
    Dim t As Double: t = Timer

    ' Define constants.
    Const SRC_FILTER_COLUMN As Long = 18
    Const SRC_FILTER_VALUE As Variant = 1 ' #3/29/2024# ' #2:22:22 PM# ' Empty
    Const SRC_MATCH_CASE As Boolean = False ' considered only if string
    Const DST_SHEET_NAME As String = "HEX Acima"
    Const DST_FIRST_CELL_ADDRESS As String = "A2"
    Const SAVE_FILE As Boolean = False
    
    ' Retrieve the data type of source filter value
    ' and determine the compare method if String data type.
    
    Dim vType As Long: vType = VarType(SRC_FILTER_VALUE)
    
    Dim CompareMethod As Long
    Select Case vType
        Case vbInteger, vbLong, vbSingle, vbDouble: vType = vbDouble
        Case vbString: CompareMethod = SRC_MATCH_CASE + 1
    End Select
    
    ' Reference the source worksheet.
    Dim sws As Worksheet: Set sws = ActiveSheet
    
    ' Reference the source data range (no headers).
    
    Dim srg As Range, srCount As Long, cCount As Long
    
    With sws.Range("A1").CurrentRegion
        cCount = .Columns.Count
        srCount = .Rows.Count - 1
        If srCount < 1 Then
            MsgBox "Not enough rows!", vbExclamation
            Exit Sub
        End If
        Set srg = .Resize(srCount).Offset(1)
    End With
    
    ' Return the values from the source data range in a 2D one-based array.
    Dim Data() As Variant: Data = srg.Value
    
    ' Write the rows with a match to the top of the array.
    
    Dim Value As Variant, sr As Long, c As Long, drCount As Long
    Dim IsEqual As Boolean
    
    For sr = 1 To srCount
        Value = Data(sr, SRC_FILTER_COLUMN)
        If VarType(Value) = vType Then ' is correct data type
            If vType = vbString Then
                If StrComp(Value, SRC_FILTER_VALUE, CompareMethod) = 0 Then
                    IsEqual = True
                End If
            Else
                If Value = SRC_FILTER_VALUE Then IsEqual = True
            End If
        'Else ' is wrong data type; do nothing
        End If
        If IsEqual Then
            drCount = drCount + 1
            For c = 1 To cCount
                Data(drCount, c) = Data(sr, c)
            Next c
            IsEqual = False ' reset for the next iteration
        'Else
        End If
    Next sr
    
    ' Reference the workbook.
    Dim wb As Workbook: Set wb = sws.Parent
    ' Reference the destination worksheet.
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET_NAME)
    
    ' Reference the destination first row range.
    Dim drg As Range:
    With dws.Range(DST_FIRST_CELL_ADDRESS)
        Set drg = .Resize(, cCount)
    End With
    
    ' Returne the matching rows in the destination range
    ' and set a flag indicating whether a row with a match was found.
    
    Dim WereMatchesFound As Boolean:
    If drCount > 0 Then
        ' Resize the destination range to cover all rows with a match.
        Set drg = drg.Resize(drCount)
        ' Copy values from the top of the array to the destination range.
        drg.Value = Data
        WereMatchesFound = True ' set flag
    'Else ' no matching rows; do nothing
    End If
    
    ' Clear below.
    drg.Resize(dws.Rows.Count - drg.Row - drCount + 1).Offset(drCount).Clear

    ' Inform.
    If WereMatchesFound Then
        ' Save the workbook.
        If SAVE_FILE Then wb.Save
        ' Retrieve the time passed.
        t = Timer - t
        MsgBox drCount & " filtered row" & IIf(drCount = 1, "", "s") _
            & " copied in roughly " & Round(t, 3) & " s.", vbInformation
    Else
        MsgBox "No rows with a match in column " _
            & SRC_FILTER_COLUMN & " in worksheet """ & sws.Name _
            & """ of workbook """ & wb.Name & """ found!", vbExclamation
    End If
    
End Sub