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. I would expect it has to run for close to 10 days. 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?
Note: I've added //comments just for CR/SO, they are not in VBA.