筛选数据集时不粘贴复制功能

Question

我有以下代码，用于复制活动行并将其多次粘贴到数据末尾的第一个空白或可用行中。 该代码提示用户指定将复制的行粘贴到数据末尾的次数。 但是，当在某个字段上过滤正在使用它的数据集时，它不能正常工作。 而是将其粘贴到已过滤数据内的现有数据上。 例如，如果由于应用了过滤器选择而导致行699不可见，并且数据在行700处结束，那么701将是第一个空白行，它将粘贴在行699上。但是，当用户保存时，它确实起作用在两者之间。 关于如何解决此问题有任何想法吗？

Sub Transfer()

Application.ScreenUpdating = False

Dim lastrow As Long
lastrow = Sheets("ForecastedMovement").Range("A65536").End(xlUp).Row    '   or + 1

On Error GoTo Finish
lngRows = CLng(InputBox("How many rows do you wish to add?"))
lngNextRow = Range("A" & Rows.Count).End(xlUp).Row + 1

Range("A" & ActiveCell.Row & ":BX" & ActiveCell.Row).Copy
Range("A" & lastrow + 1 & ":BX" & lastrow + lngRows).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Finish:
If Err.Number <> 0 Then MsgBox Prompt:="Please ensure you only enter numeric values!"

Application.ScreenUpdating = True

End Sub

Answer 1

Sub Transfer()

    Dim sht As Worksheet
    Dim lastrow As Long, lngRows

    Application.ScreenUpdating = False

    Set sht = Sheets("ForecastedMovement")

    lastrow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row + 1
    'account for filtered rows at end of dataset
    Do While Application.CountA(sht.Rows(lastrow)) > 0
        lastrow = lastrow + 1
    Loop

    On Error GoTo Finish
    lngRows = CLng(InputBox("How many rows do you wish to add?"))

    ActiveCell.EntireRow.Range("A1:BX1").Copy

    sht.Cells(lastrow, 1).Resize(lngRows).PasteSpecial Paste:=xlPasteValues

Finish:
    If Err.Number <> 0 Then MsgBox Prompt:="Please ensure you only enter numeric values!"

    Application.ScreenUpdating = True

End Sub