VBA复制粘贴突然重复粘贴

Question

我运行这个脚本已经有一段时间了，没有问题，但是今天它坏了。这非常简单，因为我只是从一个选项卡中筛选出值，然后将它们复制并粘贴到顶行的另一个选项卡上。突然，它会粘贴这些值，然后再重复粘贴19次，总共复制粘贴了20次。

Sheets("BSLOG").Select
Range("Q1").Select
Selection.AutoFilter Field:=17, Criteria1:="1"
Range("A1:Q5000").Select
Range("A1:Q5000").Activate
Selection.Copy
Sheets("PENDG TRADES").Select
Range("A1:Q300").Select
ActiveSheet.Paste

Answer 1

请尝试下一个代码。不需要选择，激活任何东西。在这种情况下，这些选择不会带来任何好处，它们只会消耗Excel资源：

Sub testFilterCopy()
 Dim shB As Worksheet, shP As Worksheet
 Set shB = Sheets("BSLOG")
 Set shP = Sheets("PENDG TRADES")

 shB.Range("Q1").AutoFilter field:=17, Criteria1:="1"
 shB.Range("A1:Q5000").Copy shP.Range("A1")
End Sub

如果您想使范围成为动态的(就行而言)，我可以向您展示如何初始计算现有的行数，并根据它设置要复制的范围。

Answer 2

FaneDuru是对的。你也可以试试这段代码，我更喜欢它：

Option Base 1 'This means all array starts at 1. It is set by default at 0. Use whatever you prefer,depending if you have headers or not, etc
Sub TestFilter()
Dim shBSLOG As Worksheet
Dim shPENDG As Worksheet
Dim rngBSLOG As Range
Dim arrBSLOG(), arrCopy()
Dim RowsInBSLOG&
Dim i&, j&, k&

Set shBSLOG = Worksheets("BSLOG")
Set shPENDG = Worksheets("PENDG TRADES")

With shBSLOG
    Set rngBSLOG = .Range(.Cells(1, 1), .Cells(5000, 17))
End With
    RowsInBSLOG = rngBSLOG.Rows.Count
    arrBSLOG = rngBSLOG
    
    ReDim arrCopy(1 To RowsInBSLOG, 1 To 17) 'set the size of the new array as the original array
    
k = 1 'k is set to 1. This will be used to the row of the new array "arrCopy"
For i = 1 To RowsInBSLOG 'filter the array. From the row "i" = 1 to the total of rows "RowsinBSLOG
    If arrBSLOG(i, 1) = 1 Then 'if the first column of the row i is equal to 1, then...
        For j = 1 To 17
            arrCopy(k, j) = arrBSLOG(i, j) 'copy the row
        Next j
        k = k + 1 'next copy will be in a new row
    End If
Next i 'repeat

With shPENDG
    .Range(.Cells(1, 1), .Cells(k, 17)) = arrCopy() 'place the new array in the new sheet

End With

End Sub