VBA Copy Paste 突然重复粘贴

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

请尝试下一个代码。无需 select，激活任何东西。在这种情况下，这些 select 离子不会带来任何好处，它们只会消耗 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

VBA Copy Paste 突然重复粘贴

VBA Copy Paste suddenly repeating pasting

excel

vba

copy-paste