Autofilter then Copy and Paste Range

I wrote a code below. Intention is to autofilter column K with criteria, copy data and paste it at the bottom of the sheet on the same page, just below the last row.

I am not getting any error, but code is not working as intended. It works up to autofilter and copy, but it won't paste the data to the last row. Can I please get some assistance.

Sub Depreciation_to_Zero()
With Sheets("Restaurant")
.AutoFilterMode = False
With .Range("k1", .Range("k" & .Rows.Count).End(xlUp))
    .AutoFilter Field:=1, Criteria1:="*HotDog*"
    On Error Resume Next
    .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy
    .Cells(.Rows.Count, "A").End(xlUp).Row.Select.PasteSpecial xlPasteValues
    On Error GoTo 0
End With

.AutoFilterMode = False
End With
MsgBox ("Complete")
End Sub

1 answer

  • answered 2017-12-06 06:34 paul bica

    Try this version


    Option Explicit
    
    Public Sub DepreciationToZero()
    
        Const FIND_VAL = "*HotDog*"
    
        Dim ws As Worksheet, lr As Long, result As String
    
        Set ws = Worksheets("Restaurant")
        Application.ScreenUpdating = False
        ws.AutoFilterMode = False
        lr = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row
        result = FIND_VAL & " not found"
    
        With ws.UsedRange
            ws.Range("K1:K" & lr).AutoFilter Field:=1, Criteria1:=FIND_VAL
            If ws.Range("K1:K" & lr).SpecialCells(xlCellTypeVisible).CountLarge > 1 Then
                .Offset(1).Resize(lr - 1).SpecialCells(xlCellTypeVisible).Copy
                .Offset(lr).Cells(1).PasteSpecial xlPasteValues
                .Offset(lr).Cells(1).Select
                Application.CutCopyMode = False
                result = "All " & FIND_VAL & " rows copied"
            End If
        End With
    
        ws.AutoFilterMode = False
        Application.ScreenUpdating = True
        MsgBox result
    End Sub