How to filter range and copy to bottom of table in different sheet?

user_15459853 0
Viewed 139

I am trying to filter & select all columns (A to R) which contain the value "New" in column R. I then want to copy this selection and paste as value it to the bottom of the table on worksheet "Worklist".

I don't understand why the code is using an "If" function to look at the subtotal and think I did the copy & pasting part wrong, since I'm getting an error.

Sub CopyPartOfFilteredRange()
    Dim lastRow As Long
    With ThisWorkbook.Sheets("ProcessingSheet")
        .AutoFilterMode = False

        lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        With .Range("A1:R" & lastRow)
            .AutoFilter Field:=18, Criteria1:="New"
            If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then 'count visible cells in column "A" other than the header
                .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Destinations:=Sheets("Worklist").Cells(.Range("B" & .Rows.Count).End(xlUp).Row + 1, 1)
            End If
    
        End With
     End With
End Sub
autofilter vba excel
2 Answers

Copy Filtered Data feat. Subtotal

  • Range.Subtotal method

  • SpeacialCells will raise an error if no matching values are found by the AutoFilter. Subtotal is used to avoid this by returning the number of found values.

The Code

Option Explicit

Sub CopyPartOfFilteredRange()
    With ThisWorkbook.Sheets("ProcessingSheet")
        .AutoFilterMode = False
        Dim lastRow As Long: lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        With .Range("A1:R" & lastRow)
            .AutoFilter Field:=18, Criteria1:="New"
            If WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then
                Dim dws As Worksheet
                Set dws = ThisWorkbook.Worksheets("Worklist")
                .Offset(1).Resize(.Rows.Count - 1) _
                    .SpecialCells(xlCellTypeVisible).Copy _
                    Destination:=dws.Cells(dws.Range("B" & dws.Rows.Count) _
                    .End(xlUp).Row + 1, 1)
            End If
        End With
        .AutoFilterMode = False
     End With
End Sub
user_98140690

Please try the following code and let me know how you go. It works (tested) based on your description of the data.

Option Explicit

Sub CopyPartOfFilteredRange()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim LRow As Long, PasteRow As Long
Dim rng As Range

Set ws1 = ThisWorkbook.Worksheets("ProcessingSheet")
Set ws2 = ThisWorkbook.Worksheets("Worklist")

LRow = ws1.Cells(Rows.Count, 18).End(xlUp).Row
PasteRow = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1

Set rng = ws1.Range("A1:R" & LRow)

With rng
    .AutoFilter 18, "New"
    .Offset(1).Copy ws2.Cells(PasteRow, 2)
    .AutoFilter
End With

End Sub
Admin1
Related