Repeating Macro gets error after several run throughs

Question

Sample WorkbookI have repeating macros that freeze with an error after running 500 to 600 times through. The number of times I need it to run will change every time but mostly be around 2000 times.Error Notice

Line of code it stops onMaE.png

The entire code is below, multiple macros running after each other and calling others until report completes. It runs fine if it runs less than 500 times.

    Sub Start_New_Report()
'
' Start_New_Report Macro
' Clear Old data and prepare for new lines.
'
    Application.ScreenUpdating = False
    Sheets("Filtered Report").Select
    Range("A2:I1048576").Select
    Selection.ClearContents
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "1"

    Call Filter_Data

End Sub

Sub Filter_Data()
' Filter raw Syteline data to usable lines

    Worksheets("Filtered Report").Range("B2").Value = _
        Worksheets("PurchaseOrderStatus").Range("A5:E5").Value
    Worksheets("Filtered Report").Range("C2").Value = _
        Worksheets("PurchaseOrderStatus").Range("A6:C6").Value
    Worksheets("Filtered Report").Range("D2").Value = _
        Worksheets("PurchaseOrderStatus").Range("A7:F7").Value
    Worksheets("Filtered Report").Range("E2").Value = _
        Worksheets("PurchaseOrderStatus").Range("J5").Value
    Worksheets("Filtered Report").Range("F2").Value = _
        Worksheets("PurchaseOrderStatus").Range("O7").Value
    Worksheets("Filtered Report").Range("G2").Value = _
        Worksheets("PurchaseOrderStatus").Range("P6:R6").Value
    Worksheets("Filtered Report").Range("H2").Value = _
        Worksheets("PurchaseOrderStatus").Range("P7:T7").Value
    Worksheets("Filtered Report").Range("I2").Value = _
        Worksheets("PurchaseOrderStatus").Range("V7").Value

    Call Clear_Raw_Data

End Sub

 Sub Clear_Raw_Data()
' Clear Raw Data Lines

    Sheets("PurchaseOrderStatus").Select
    Rows("5:7").Delete

    Call Blank_Cells

End Sub

Sub Blank_Cells()
' Check if blank cells exist in current line

    Sheets("Filtered Report").Select
    Range("B2").Select
If IsEmpty(Range("B2").Value) Then
    Call Copy_Up
Else
    Call Blank_Cells_Raw_Data
End If

End Sub

Sub Copy_Up()
'
' Copy Data Up from line below if cells are empty.
'
    Range("B3:D3").Copy Range("B2:D2")

    Call Blank_Cells_Raw_Data

End Sub

Sub Blank_Cells_Raw_Data()

    Sheets("PurchaseOrderStatus").Select
    Range("V5").Select
If IsEmpty(ActiveCell.Value) Then
    Call Finalize_Report
Else
    Call Clear_for_Next_Line
End If

End Sub

Sub Clear_for_Next_Line()
'
' Clear_for_Next_Line Macro
'
' Insert_line Macro
    Sheets("Filtered Report").Select
    Range("2:2").Insert CopyOrigin:=xlFormatFromRightOrBelow

' Create next index number

    Worksheets("Filtered Report").Range("A2").Value = _
        Worksheets("Filtered Report").Range("A3").Value + 1

    Call Filter_Data

End Sub

Sub Finalize_Report()
'
' Finalize_Report Macro
' Finish report and sort the order.
'
    Sheets("Filtered Report").Select
    Range("A1") = "Index"
    Columns("A:I").Sort key1:=Range("A2"), _
      order1:=xlAscending, Header:=xlYes

End Sub

Answer 1

In essence, I discarded the entire model where separate subroutines were calling each other in sequence and replaced it with a single subroutine that performs all of the functions.

• I opted to rewrite the sample code by removing the use of .Select (see link) and defining worksheet variables whenever possible.

• One other thing I noticed was in Blank_Cells and Blank_Cells_Raw_Data, I don't think you meant to use IsEmpty there (which checks to see if a variable is initialized; see link), but rather determine if the cell itself is empty. I changed this to If Application.WorksheetFunction.CountA(Range) = 0 in both instances.

• In Filter_Data, I noticed you're setting the value of one cell (e.g. B2) to the value of multiple cells (e.g. A5:E5). In testing this just set the first cell to the first value in the range defined (i.e. cell A5). Assuming you didn't mean to do something like Application.WorksheetFunction.Sum(ws2.Range("A5:E5")) (to sum the values in those cells) I just changed these to get the first cell.

• I changed Filter_Data and a few other spots to use cell/column references instead of ranges when possible.
• In Copy_Up I replaced the .Copy function with actually setting the cells to the values (Copy can get weird sometimes so I avoid using it whenever possible).
• Additionally, since .Delete and .Insert both slow down the macro considerably, I used a method that avoids doing either by just checking one group of three rows on 'PurchaseOrderStatus' at a time then moving to the next one, and by writing to the first free row on 'Filtered Report' instead of inserting new rows at the top. This sped the macro up considerably (~35 seconds to less than a second).

Option Explicit

Sub Start_New_Report()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range
Dim newRow As Long, lastRow As Long, x As Long

Set ws1 = ThisWorkbook.Sheets("Filtered Report")
Set ws2 = ThisWorkbook.Sheets("PurchaseOrderStatus")

' Turn screen updating / calculation off for speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

' Clear Old data and prepare for new lines.
ws1.Range(ws1.Cells(2, 1), ws1.Cells(10000, 9)).ClearContents
ws1.Cells(2, 1) = 1

' Define last row
lastRow = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row - 2

' Iterate through all groups of 3 rows on PurchaseOrderStatus sheet
For x = 5 To lastRow Step 3

    ' Determine new row to write to
    newRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row

    ' Filter raw Syteline data to usable lines
    ws1.Cells(newRow, 2) = ws2.Cells(x, 1)
    ws1.Cells(newRow, 3) = ws2.Cells(x + 1, 1)
    ws1.Cells(newRow, 4) = ws2.Cells(x + 2, 1)
    ws1.Cells(newRow, 5) = ws2.Cells(x, 10)
    ws1.Cells(newRow, 6) = ws2.Cells(x + 2, 15)
    ws1.Cells(newRow, 7) = ws2.Cells(x + 1, 16)
    ws1.Cells(newRow, 8) = ws2.Cells(x + 2, 16)
    ws1.Cells(newRow, 9) = ws2.Cells(x + 2, 22)

    ' Copy Data Up from line below if cells are empty.
    If Application.WorksheetFunction.CountA(ws1.Cells(newRow, 2)) = 0 Then
        ws1.Cells(newRow, 2) = ws1.Cells(newRow - 1, 2)
        ws1.Cells(newRow, 3) = ws1.Cells(newRow - 1, 3)
        ws1.Cells(newRow, 4) = ws1.Cells(newRow - 1, 4)
    End If

    ' Create next index number if not the last row
    If x <> lastRow Then
        ws1.Cells(newRow + 1, 1) = ws1.Cells(newRow, 1).Value + 1
    End If

Next x

' Finish report and sort the order.
ws1.Range(ws1.Columns(1), ws1.Columns(9)).Sort _
    Key1:=ws1.Cells(2, 1), _
    Order1:=xlAscending, _
    Header:=xlYes

' Turn screen updating / calculation back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub