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

Do you have any things being calculated in cells? If so, placing these lines at the top and on at the bottom, respectively, might help: Application.Calculation=xlManual and Application.Calculation=xlAutomatic — Matt Cremeens
– Matt Cremeens, Commented Jan 19, 2017 at 16:47
I assume the // are comments you added for SO, not in the code itself? (because ' is the comment marker for VBA). If you step through the code with F8, where does the loop seem to get stuck? Also possibly add some breaks in each part of the loop to help figure where the loop is taking more time than expected. — BruceWayne
– BruceWayne, Commented Jan 19, 2017 at 16:47
If your code works as intended (performance aside - test it with a small data set to be sure), then the best place to ask for feedback and optimization tips is on Code Review, not Stack Overflow. — Mathieu Guindon
– Mathieu Guindon, Commented Jan 19, 2017 at 16:53
You problem will be due to the Do While y and Do While x loops continuing "forever" once Cells(i, 9) or Cells(i, 12) are Empty (which will happen once i reaches a completely empty row, which will happen because you are deleting rows but still looping through to what was the last row number before you deleted anything). You could try changing your loop to be For i = lastrow To 2 Step -1. I haven't analysed what you are doing enough to determine whether that will give you any other issues, but it should get rid of the problem caused by comparisons against empty cells. — YowE3K
– YowE3K, Commented Jan 19, 2017 at 18:26
Or you could possibly just add a statement saying If IsEmpty(Cells(i, "A")) Then Exit For immediately after the For i = 2 To lastrow statement. — YowE3K
– YowE3K, Commented Jan 19, 2017 at 18:28

dashnick · Accepted Answer · 2017-01-19 23:48:04Z

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.

edited Jan 19, 2017 at 23:48

answered Jan 19, 2017 at 20:20

dashnick

2,0781 gold badge22 silver badges37 bronze badges

Sign up to request clarification or add additional context in comments.

Collectives™ on Stack Overflow

Making VBA script run faster

1 Answer 1

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

Comments

Your Answer

Sign up or log in

Post as a guest

Related