[英]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. 目的是使用条件自动过滤K列,复制数据并将其粘贴在同一页上工作表的底部,即最后一行的下方。
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
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.