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

复制函数在过滤数据集时不粘贴

1 个答案: