Making VBA script run faster

Question

For the first time I've worked in Excel VBA to find rows in my dataset that contain the same adress as another entry in a cluster. These entries have to be merged and the row then is deleted. I've come up with the following, which works (As far as I can tell from the testing I did on small samples of the set):

Sub Merge_Orders()

Application.ScreenUpdating = False
Application.DisplayStatusBar = False

Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Dim y As Long
Dim x As Long
Dim j As Long
Dim k As Long

For i = 2 To lastrow //for each row, starting below header row
  j = 1
  y = (Cells(i, 9)) //this is the clusternumber
  Do While y = (Cells(i + j, 9)) //while the next row is in the same cluster
    x = (Cells(i, 12)) //this is the adresscode
    k = 1
    Do While x = (Cells(i + k, 12)) //while the current adresscode is the same as the next, iterating until another adresscode is hit
      Cells(i, 16) = Val(Cells(i, 16)) + Val(Cells(i + k, 16)) //update cell value
      Cells(i, 18) = Cells(i, 18) + Cells(i + k, 18)  //update cell value
      Cells(i, 19) = Cells(i, 19) + Cells(i + k, 19)  //update cell value
      If Cells(i, 20) > Cells(i + k, 20) Then
        Cells(i, 20) = Cells(i + k, 20)  //update cell value
      End If
      If Cells(i, 21) > Cells(i + k, 21) Then
        Cells(i, 21) = Cells(i + k, 21)  //update cell value
      End If
      Cells(i, 22) = Cells(i, 22) + Cells(i + k, 22)  //update cell value
      Cells(i, 23) = Cells(i, 23) + Cells(i + k, 23)  //update cell value

      Rows(i + 1).EntireRow.Delete //Delete the row from which data was pulled
      k = k + 1
    Loop
    j = j + 1
  Loop
Next i

Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub

The problem I'm facing is time. Testing this on a small sample of ~50 rows took over 5 minutes. My entries total over 100K rows. It's been running for over a day with no end in sight. Is there a way to optimize this so I don't have to wait until I'm grey?

Kind regards,

Rob

Answer 1

Two things as I mentioned in the comments:

1) Remove k (and the entire k=k+1 line); replace with j. Also replace your Rows(i + 1).EntireRow.Delete with Rows(i + j).EntireRow.Delete.

2) Since you are deleting rows, lastrow is actually blank by the time you get there. Instead of i=2 to lastrow, make it do while Cells(i,12)<>"" or something. This is causing it to loop over a bunch of rows that are empty.

Also, you can do these type of rollups much easier with a PivotTable, or, as mentioned in the comments, with an SQL GROUP BY.