Suggestions to speed up/improve this VBA script? - excel

Question

Any suggestions or tips to make this run better? I have used it on smaller data sets (100-1000 rows) and it works perfectly. Trying to run it on a data set of about 100,000 rows and it results in unresponsiveness while running and me having to force quit excel.
Sub CombineSchARecords()
Dim myRow As Long
'Row data starts
myRow = 2
Application.ScreenUpdating = False
'Loop until out of data
Do Until Cells(myRow, "A") = ""
'Check to see if next row is for same filing number
If Cells(myRow, "A") = Cells(myRow + 1, "A") Then
'Add data to correct column
Cells(myRow, "B") = Cells(myRow, "B") & ", " & Cells(myRow + 1, "B") 'SchA-3
Cells(myRow, "C") = Cells(myRow, "C") & ", " & Cells(myRow + 1, "C") 'Schedule
Cells(myRow, "D") = Cells(myRow, "D") & " | " & Cells(myRow + 1, "D") 'Full Legal Name
Cells(myRow, "E") = Cells(myRow, "E") & ", " & Cells(myRow + 1, "E") 'DE/FE/I
Cells(myRow, "F") = Cells(myRow, "F") & ", " & Cells(myRow + 1, "F") 'Entity in Which
Cells(myRow, "G") = Cells(myRow, "G") & ", " & Cells(myRow + 1, "G") 'Title or Status
Cells(myRow, "H") = Cells(myRow, "H") & ", " & Cells(myRow + 1, "H") 'Status Aquired
Cells(myRow, "I") = Cells(myRow, "I") & ", " & Cells(myRow + 1, "I") 'Ownership Code
Cells(myRow, "J") = Cells(myRow, "J") & ", " & Cells(myRow + 1, "J") 'Control Person
Cells(myRow, "K") = Cells(myRow, "K") & ", " & Cells(myRow + 1, "K") 'PR
Cells(myRow, "L") = Cells(myRow, "L") & ", " & Cells(myRow + 1, "L") 'OwnerID
'Then delete row
Rows(myRow + 1).Delete
Else
myRow = myRow + 1 'Move down one row if no match
End If
Loop
Application.ScreenUpdating = True
End Sub
Thanks!

Answer 1

The standard way to get a good speedup is to in one statement read everything into one big VBA array, process that array in VBA and then put the result back into the spreadsheet in another statement. Two lines of code which touch the spreadsheet, rather than 100,000+ spreadsheet read/writes in a loop
In terms of your problem this would mean something like:
Sub CombineSchARecords()
Dim n As Long, i As Long, j As Long
Dim numRecords As Long
Dim Values As Variant, Processed As Variant
n = Cells(Rows.Count, 1).End(xlUp).Row
Values = Range(Cells(2, "A"), Cells(n, "K")).Value
ReDim Processed(1 To n - 1, 1 To 11)
'initialize first row of Processed
For j = 1 To 11
Processed(1, j) = Values(1, j)
Next j
numRecords = 1
'main loop
For i = 2 To n - 1
If Values(i, 1) = Processed(numRecords, 1) Then
For j = 2 To 11
Processed(numRecords, j) = Processed(numRecords, j) & IIf(j = 4, " | ", ", ") & Values(i, j)
Next j
Else 'start processing a new record
numRecords = numRecords + 1
For j = 1 To 11
Processed(numRecords, j) = Values(i, j)
Next j
End If
Next i
'redim Values and copy records over
ReDim Values(1 To numRecords, 1 To 11)
For i = 1 To numRecords
For j = 1 To 11
Values(i, j) = Processed(i, j)
Next j
Next i
'finally:
Range(Cells(2, "A"), Cells(n, "K")).ClearContents
Range(Cells(2, "A"), Cells(numRecords + 1, "K")).Value = Values
End Sub

Answer 2

Besides of the use VBA array to define your variable, you may use below code to speedup your script as well.
Application.Calculation = xlManual
'Your code between this
Application.Calculation = xlAutomatic