Optimising Read/Write Speed of Excel VBA Copy/Paste Macro-CodePudding

I have an Excel sheet that connects to third party software which populates Sheet1 with data. It does this multiple times per second and overwrites previous data.

I have written the macro below to copy and paste the data to a sheet (called Data) each time there is a change to Sheet1.

It works ok put seems to be very resource-hungry.

Are there any ways it can be optimised to make it more efficient?

Thanks

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

CodePudding user response：

Efficient way is always work through memory. You just need to store sheet to array as example. And same goes to write array to sheet.

Dim MyArrayOne As Variant
Dim MyArrayTwo As Variant

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

CodePudding user response：

To expand on my comment, this is an example of what you can do:

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

Your problem is that your target range isn't rectangular. It instead seems to be relatively disjointed collection of cells.

What you could do is find a rectangular range that all those cells fit into, copy that whole range into an array, replace the values that you need and then copy the array back into the sheet. It would go something like:

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

This is obviously just a simplified example but I think you could expand it to fit your needs.

edit: this approach will convert all formulas in the targetRange to values. Not sure how to get around this atm.