优化Excel VBA复制/粘贴宏的读写速度

Question

我有一个连接到第三方软件的 Excel 工作表，该软件使用数据填充 Sheet1。它每秒执行多次并覆盖以前的数据。

每次 Sheet1 发生更改时，我都编写了下面的宏来将数据复制并粘贴到工作表（称为数据）中。

它工作正常，但似乎非常耗费资源。

有什么方法可以优化它以提高效率吗？

谢谢

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Columns.Count <> 16 Then Exit Sub

    Dim KeyCells As Range
    Set Target = ThisWorkbook.Worksheets("Sheet1").Range("F2")
' The variable KeyCells contains the cells that will
    ' cause an alert when they are changed.
    Set KeyCells = ThisWorkbook.Worksheets("Sheet1").Range("A1:P50")
    
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then
           
'Count the cells to copy
Dim a As Integer
a = 0
For i = 5 To 12
If ThisWorkbook.Sheets("Sheet1").Cells(i, 1) <> "" Then
a = a + 1
End If
Next i

'Count the last cell where to start copying
Dim b As Long
b = 2
For i = 2 To 10000
If ThisWorkbook.Sheets("Data").Cells(i, 1) <> "" Then
b = b + 1
End If
Next i

Dim c As Integer
c = 5
'Perform the copy paste process
Application.EnableEvents = False
For i = b To b + a - 1

If ThisWorkbook.Worksheets("Sheet1").Range("E2") <> "" And ThisWorkbook.Worksheets("Sheet1").Range("F2") = "" And ThisWorkbook.Worksheets("Sheet1").Range("AB5") = "35" Then
ThisWorkbook.Sheets("Data").Cells(i, 1) = ThisWorkbook.Sheets("Sheet1").Cells(3, 14)
ThisWorkbook.Sheets("Data").Cells(i, 2) = ThisWorkbook.Sheets("Sheet1").Cells(2, 2)
ThisWorkbook.Sheets("Data").Cells(i, 3) = ThisWorkbook.Sheets("Sheet1").Cells(1, 1)
ThisWorkbook.Sheets("Data").Cells(i, 4) = ThisWorkbook.Sheets("Sheet1").Cells(2, 5)
ThisWorkbook.Sheets("Data").Cells(i, 5) = ThisWorkbook.Sheets("Sheet1").Cells(c, 26)
ThisWorkbook.Sheets("Data").Cells(i, 6) = ThisWorkbook.Sheets("Sheet1").Cells(c, 1)
ThisWorkbook.Sheets("Data").Cells(i, 7) = ThisWorkbook.Sheets("Sheet1").Cells(c, 6)
ThisWorkbook.Sheets("Data").Cells(i, 8) = ThisWorkbook.Sheets("Sheet1").Cells(c, 8)
ThisWorkbook.Sheets("Data").Cells(i, 9) = ThisWorkbook.Sheets("Sheet1").Cells(c, 15)
ThisWorkbook.Sheets("Data").Cells(i, 10) = ThisWorkbook.Sheets("Sheet1").Cells(c, 16)
ThisWorkbook.Sheets("Data").Cells(i, 11) = ThisWorkbook.Sheets("Sheet1").Cells(3, 2)
ThisWorkbook.Sheets("Data").Cells(i, 12) = ThisWorkbook.Sheets("Sheet1").Cells(c, 7)
ThisWorkbook.Sheets("Data").Cells(i, 13) = ThisWorkbook.Sheets("Sheet1").Cells(c, 2)
ThisWorkbook.Sheets("Data").Cells(i, 14) = ThisWorkbook.Sheets("Sheet1").Cells(c, 3)
ThisWorkbook.Sheets("Data").Cells(i, 15) = ThisWorkbook.Sheets("Sheet1").Cells(c, 4)
ThisWorkbook.Sheets("Data").Cells(i, 16) = ThisWorkbook.Sheets("Sheet1").Cells(c, 5)
ThisWorkbook.Sheets("Data").Cells(i, 17) = ThisWorkbook.Sheets("Sheet1").Cells(c, 9)
ThisWorkbook.Sheets("Data").Cells(i, 18) = ThisWorkbook.Sheets("Sheet1").Cells(c, 12)
ThisWorkbook.Sheets("Data").Cells(i, 19) = ThisWorkbook.Sheets("Sheet1").Cells(c, 13)
ThisWorkbook.Sheets("Data").Cells(i, 20) = ThisWorkbook.Sheets("Sheet1").Cells(c, 10)
ThisWorkbook.Sheets("Data").Cells(i, 21) = ThisWorkbook.Sheets("Sheet1").Cells(c, 11)
ThisWorkbook.Sheets("Data").Cells(i, 22) = ThisWorkbook.Sheets("Sheet1").Cells(c, 25)

c = c + 1
End If
Next i
Application.EnableEvents = True

End If

End Sub

Answer 1

有效的方法总是通过记忆来工作。例如，您只需要将工作表存储到数组即可。将数组写入工作表也是如此。

Dim MyArrayOne As Variant
Dim MyArrayTwo As Variant

MyArrayOne = Sheets(1).Range("A1:V99").Value
MyArraytWO = Sheets(2).Range("A1:V99").Formula

Answer 2

为了扩展我的评论，这是您可以执行的操作的示例：

Sub arrtest()
    Dim arr(1, 1) As Variant
    arr(0, 0) = 1
    arr(0, 1) = 2
    arr(1, 0) = 3
    arr(1, 1) = 4
    Range(Cells(1, 1), Cells(2, 2)) = arr
End Sub

您的问题是您的目标范围不是矩形。相反，它似乎是相对不连贯的细胞集合。

您可以做的是找到一个适合所有这些单元格的矩形范围，将整个范围复制到一个数组中，替换您需要的值，然后将数组复制回工作表中。它会是这样的：

Sub intputarrtest()
    Dim arr() As Variant, targetRange As Range
    '"assign range A1:C2 to the targetRange variable"
    Set targetRange = Range(Cells(1, 1), Cells(2, 3))
    '"copy targetRange to the arr array"
    arr = targetRange
    
    '"change some values"
    arr(1, 1) = "hello"
    arr(1, 2) = "there"
    
    '"copy the array back into the sheet"
    targetRange = arr
End Sub

这显然只是一个简化的示例，但我认为您可以扩展它以满足您的需要。

编辑：此方法会将 targetRange 中的所有公式转换为值。不知道如何绕过这个自动取款机。