VBA Macro Stops/Hangs Excel after about 4000 Iterations - excel

Question

I am posting this on behalf of someone else. Hoping I learn something in the process.
One of my team members is working on an excel macro that loops through the rows in a spreadsheet that contains over 14,000 rows. With each loop, it moves relevant data into a new tab within the workbook. The loop completes successfully unless we use the LastRow variable, or if we tell it to go for more than 400-4500 rows, then it crashes or hangs without any useful error info. The behavior does not change on different machines. We are using Excel 2016 to run the macro. I wanted to share the code with you to see if there is something that is causing it to hang (But why would it work fine for up to 4000 rows, and then quit beyond? I suspect memory issues to be the cause...)
I am sorry if this is answered elsewhere, I am not experienced enough to recognize if certain suggestions apply to this particular code.
Here is the code:
Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
SheetExists = Not sht Is Nothing
End Function
Sub SortProductionIntoWorkcenters()
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
LastRow = Worksheets("TL Production").Cells.SpecialCells(Type:=XlCellType.xlCellTypeLastCell).Row
FirstRow = 3
Dim rng As Range, cel As Range
'The next line that says Cells(LastRow, 4)) is where I can change how may iterations the loop will process
Set rng = Worksheets("TL Production").Range(Cells(FirstRow, 4), Cells(LastRow, 4))
Dim SheetName As String
Dim r As Integer
r = 2
For Each cel In rng
Worksheets("TL Production").Select
If Cells(cel.Row, cel.Column) = "" Then
Cells(cel.Row, cel.Column) = "EMPTY"
End If
SheetName = Worksheets("TL Production").Cells(cel.Row, 4).Value
SheetName = Replace(SheetName, "/", " ")
If Not SheetExists(SheetName) Then
Worksheets.Add.Name = SheetName
End If
Worksheets("TL Production").Rows(cel.Row).Cut
Do While r > 0
If IsEmpty(Worksheets(SheetName).Cells(r, 1)) Then
Worksheets(SheetName).Rows(r).Insert shift:=xlDown
r = 2
Exit Do
End If
r = r + 1
Loop
Next cel
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
'MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
' MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
End Sub

Answer 1

Not an answer, but you would really benefit from simplifying your code. Eg:
For Each cel In rng
Worksheets("TL Production").Select
If cel = "" Then
cel = "EMPTY"
End If
SheetName = cel
etc...

Answer 2

Although I'm not entirely sure what the real issue in your code is (could very well be memory related), I see a couple of things that can improve your code, as well as its performance. See the bottom of the post for my proposal of a revised version of your code.
For Each cel In rng
Worksheets("TL Production").Select
If Cells(cel.Row, cel.Column) = "" Then
Cells(cel.Row, cel.Column) = "EMPTY"
End If
Executing .Select every single loop slows down your code drastically, as each .rows(r).Insert seems to change to another sheet. So your code forces Excel to constantly switch Worksheets. Redrawing the screen is orders of magnitude slower than performing calculations or reading some values from the sheet.
This can be further mitigated by completely switching off screen updating:
Application.ScreenUpdating = False
ws.Select
For Each cel In rng.Cells
...
Next cel
Application.ScreenUpdating = True
As mentioned by #PatrickHonorez, Cells(cel.Row, cel.Column) is a little bit overdoing it. It's a more complicated way of referencing cel - so why not use that directly? :) It also has the pitfall of not necessarily returning the correct cell, due to not being fully referenced. (Cells actually means ActiveWorkbook.ActiveSheet.Cells, so if your Workbook/Sheet change due to whatever reason, your script suddenly runs into trouble.)
If cel.Value = "" Then
cel.Value = "EMPTY"
End If
As mentioned in a comment by #dwirony, the While r > 0 condition in the Do Loop isn't really doing anything. There is no path through your code that allows for r < 2. Also, the way this loop is constructed is the major contributor to the macro's slow execution. (Several thousand rows in the original sheet means we enter this particular loop the equally often, and each time it has to count a little higher, due to the target sheets growing.)
I think this would be a good place to use a dictionary to store the number of the last row you inserted:
Do While r > 0
DoEvents
If IsEmpty(Worksheets(SheetName).Cells(r, 1)) Then
Worksheets(SheetName).Rows(r).Insert shift:=xlDown
dict(SheetName) = r
Exit Do
End If
r = r + 1
Loop
Generally:
Use Option Explicit at the top of any module. It will make your life easier. (Thus the compiler will force you to declare each and every variable you use. This makes your code more concise and eliminates potential typos, among other benefits.) You can also make this the standard in the VBA IDE's options.
If the sheets modified by your macro contain formulas you can deactivate automatic recalculation (if not already set to manual) with Application.Calculation = xlCalculationManual - this will in some cases further reduce execution times. If you want to set it back to automatic afterwards, use Application.Calculation = xlCalculationAutomatic.
Add a line DoEvents to each and every Do Loop you don't perfectly trust. This will allow you stop/pause the macro if it turns out to be an (almost) infinite loop.
My revised version, I tested it with about 6000 rows to be distributed to 3 different worksheets. It took about 2min to complete. Although rows with more data might take longer than my quick mock-up.
Sub SortProductionIntoWorkcenters()
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim LastRow As Long, FirstRow As Long
Dim Ws As Worksheet
Dim Dict As Scripting.Dictionary
StartTime = Timer
Set Dict = New Scripting.Dictionary
Set Ws = Worksheets("TL Production") ' Set the reference to the starting sheet once and then use that
LastRow = Ws.Cells.SpecialCells(Type:=XlCellType.xlCellTypeLastCell).Row
FirstRow = 3
Dim rng As Range, cel As Range
'The next line that says Cells(LastRow, 4)) is where I can change how may iterations the loop will process
Set rng = Ws.Range(Cells(FirstRow, 4), Cells(LastRow, 4))
Dim SheetName As String
Dim r As Long ' Use Long datatype here to prevent integer overflow
r = 2
Application.ScreenUpdating = False
For Each cel In rng.Cells ' make explicit that we are iterating over all cells in range
If cel.Value = "" Then
cel.Value = "EMPTY"
End If
SheetName = Ws.Cells(cel.Row, 4).Value
SheetName = Replace(SheetName, "/", " ")
If Not SheetExists(SheetName) Then
Worksheets.Add.Name = SheetName
End If
Ws.Rows(cel.Row).Cut
If Dict.Exists(SheetName) Then r = Dict(SheetName)
Do
DoEvents
If IsEmpty(Worksheets(SheetName).Cells(r, 1)) Then
Worksheets(SheetName).Rows(r).Insert shift:=xlDown
Dict(SheetName) = r + 1 ' Add one, as the row r is not empty by defition
Exit Do
End If
r = r + 1
Loop
Next cel
Application.ScreenUpdating = True
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
'MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
' MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
End Sub