自動過濾，然后復制和粘貼范圍

Question

我在下面寫了一個代碼。 目的是使用條件自動過濾K列，復制數據並將其粘貼在同一頁上工作表的底部，即最后一行的下方。

我沒有收到任何錯誤，但是代碼未按預期工作。 它可以自動過濾和復制，但不會將數據粘貼到最后一行。 請給我一些幫助。

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

Answer 1

試試這個版本

---

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