VBA slowing down if sub procedure runs twice in same workbook?

Question

I'm working with a fairly large workbook (50MB), and I'm trying to run a procedure that iterates through all cells in a table (yes I know this is slow, but it's unavoidable) and deletes some and formats others.

It turns out that it is much faster to copy the data to a fresh workbook, and run the procedure, for whatever reason.

However, I'm trying to repeat this procedure with 5 different tables (I've only coded 2 so far), and I'm experiencing a lot of slowdown if I run the procedure twice from the same workbook. The slowdown is close to an order of magnitude.

If I only run 1 of the procedures, they run in less than a minute, easily. However, when I run both of them, the second one just CRAWLS (separately the second one takes ~4 seconds)

Does anyone know why this might be?

I've included my code below.

Sub FormatNewSchedules()

StartTime = Timer
Application.Calculation = xlManual
Application.ScreenUpdating = False

' Set Up New Schedule Workbook
Windows("New Schedule.xlsx").Activate
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Master Schedule"
Sheets.Add After:=ActiveSheet
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Burn Schedule"
Sheets.Add After:=ActiveSheet
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "Weld Xray Schedule"
Sheets.Add After:=ActiveSheet
Sheets("Sheet3").Select
Sheets("Sheet3").Name = "Press Schedule"
Sheets.Add After:=ActiveSheet
Sheets("Sheet4").Select
Sheets("Sheet4").Name = "Pickle Schedule"


' Copy All Schedules

    ' Copy Master Schedule (Source) to New Schedule
    Call CopySource("Master Schedule", 10, "BE", 13, 1)


    ' Copy Burn Schedule (Source) to New Schedule
    Call CopySource("Burn Schedule", 9, "AA", 3, 1)

' Clean up
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

' How much time?
EndTime = Timer
TimeCalc = EndTime - StartTime
MsgBox Format(TimeCalc / 86400, "hh:mm:ss")

Application.StatusBar = False

End Sub

Here's the Sub Procedure I'm calling multiple times:

Sub CopySource(SourceName As String, FR As Integer, LC As String, _
    Categories As Integer, NumHeaderRows As Integer)

    Dim i As Integer

    ' Copy Data from Master Schedule to New Schedule
    Dim LRSource As Integer
    LRSource = Workbooks("Master Schedule").Sheets(SourceName & " (Source)"). _
    Cells(Rows.Count, 1).End(xlUp).Row

    Workbooks("Master Schedule").Sheets(SourceName & " (Source)"). _
        Range("A" & FR & ":" & LC & LRSource).Copy
    Workbooks("New Schedule").Sheets(SourceName).Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

    ' Table Dimensions
    Dim LastRow As Integer

    LastRow = Sheets(SourceName).Cells(Rows.Count, 1).End(xlUp).Row


    ' Delete every 3rd cell in Header Column
    For i = 0 To Categories - 1
        Range(FirstColumn & "1:" & FirstColumn & NumHeaderRows). _
            Offset(0, 2 * i + 2).Delete (xlShiftToLeft)
    Next i

    Dim RowCounter As Integer
    Dim FirstRow As Integer

    FirstRow = NumHeaderRows + 1

    ' STEP 1: DELETE unnecessary cells
    For RowCounter = FirstRow To LastRow

        ' Update StatusBar
        PercentComplete = (RowCounter / (LastRow - FirstRow)) * 95
        Application.StatusBar = PercentComplete & "% Complete; Row " & RowCounter & " of " & LastRow

        'This row is NOT a Subtotal row
        If InStr(Range("A" & RowCounter).Value, "Total") = 0 _
        And InStr(Range("B" & RowCounter).Value, "Total") = 0 _
        And InStr(Range("C" & RowCounter).Value, "Total") = 0 Then

            ' Delete all RemHours + Date cells
            For i = 0 To Categories - 2
            Range(FirstColumn & RowCounter).Offset(0, 2 * i).Delete (xlShiftToLeft)
            Next i
            Range(FirstColumn & RowCounter).Offset(0, (Categories - 1) * 2 + 1).Delete (xlShiftToLeft)

        'This row IS a Subtotal row
        Else

            ' Delete all Remaining Standard Hours cells & RemHours + Date Total at end
            For i = 0 To Categories - 1
            Range(FirstColumn & RowCounter).Offset(0, 2 * i + 1).Delete (xlShiftToLeft)
            Next i
        End If
    Next RowCounter


    ' STEP 2: FORMAT each cell based on value
    For RowCounter = FirstRow To LastRow

        ' Update Status Bar
        PercentComplete = (RowCounter / LastRow) * 5 + 95
        Application.StatusBar = PercentComplete & "% Complete"

        ' Only apply to non-subtotal rows
        If InStr(Range("A" & RowCounter).Value, "Total") = 0 _
        And InStr(Range("B" & RowCounter).Value, "Total") = 0 _
        And InStr(Range("C" & RowCounter).Value, "Total") = 0 Then

            ' Apply formatting to each cell in the row
            For i = 0 To Categories - 1

                Select Case Range(FirstColumn & RowCounter).Offset(0, 2 * i).Value
                    ' Cell value is VALID DATE
                    Case Is > 41275

                        ' Add Date Format and Borders
                        Range(FirstColumn & RowCounter).Offset(0, 2 * i).NumberFormat = "m/d;@"
                        With Range(FirstColumn & RowCounter).Offset(0, 2 * i).Borders
                            .LineStyle = xlContinuous
                            .Color = -10526881
                            .Weight = xlThin
                        End With
                        Range(FirstColumn & RowCounter).Offset(0, 2 * i).Interior.Color = 14540253

                    ' Cell value is INVALID DATE
                    Case 10000 To 41275

                        ' Add Date Format and Borders
                        Range(FirstColumn & RowCounter).Offset(0, 2 * i).NumberFormat = "m/d/yyyy"
                        With Range(FirstColumn & RowCounter).Offset(0, 2 * i).Borders
                            .LineStyle = xlContinuous
                            .Color = -10526881
                            .Weight = xlThin
                        End With
                        Range(FirstColumn & RowCounter).Offset(0, 2 * i).Interior.Color = 6684927
                        Range(FirstColumn & RowCounter).Offset(0, 2 * i).Font.Color = -1

                    ' Cell has REMAINING HOURS
                    Case Is > 0

                        ' Add Borders
                        With Range(FirstColumn & RowCounter).Offset(0, 2 * i).Borders
                            .LineStyle = xlContinuous
                            .Color = -10526881
                            .Weight = xlThin
                        End With

                        ' Add Databars
                        Range(FirstColumn & RowCounter).Offset(0, 2 * i).FormatConditions.AddDatabar
                        With Range(FirstColumn & RowCounter).Offset(0, 2 * i).FormatConditions(1)
                            .MinPoint.Modify xlConditionValueNumber, 0
                            .MaxPoint.Modify newtype:=xlConditionValueNumber, newvalue:= _
                                Range(FirstColumn & RowCounter).Offset(0, 2 * i + 1).Value
                            .BarFillType = xlDataBarFillSolid
                        End With

                    ' Cell is NOTHING
                        'Case Is = vbNullString
                                'Range(FirstColumn & RowCounter).Offset(0, 2 * i).Interior.Color = 6750054
                End Select
            Next i
        End If
    Next RowCounter

    'Hide Total Columns
    For i = 0 To Categories - 1
    Range(FirstColumn & "1").Offset(0, 2 * i + 1).EntireColumn.Hidden = True
    Next i

End Sub

Step 1 is actually slower (the deleting, not the formatting). In any case, for the first call to CopySource, everything is very quick. The second call takes MUCH longer than it would take individually. I finally figured out the answer, after puzzling over this for a couple days. When I call the second procedure there is already a massive amount of conditional formatting in place. Thus, Step 1 of the procedure, which is essentially a lot of cell deletion, will take MUCH longer. — Austin Wismer, Jul 12 '14 at 01:20

score 2 · Accepted Answer · answered Jul 12 '14 at 01:19

2

I've figured out the answer to this (and some other!) question.

The answer is that the formatting procedure is applying ~5000 individual conditional formatting rules to the cells. Apply the formatting itself happens very quickly.

However, any subsequent cell deletions will take a LONG time (relatively) to happen, since it has to wade through the refreshing of about 5,000 conditional formatting rules.

answered Jul 12 '14 at 01:19

Austin Wismer

281
1
4
16

2

Performance would probably benefit greatly if you avoid using Select/Activate methods :) http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros – David Zemens Jul 12 '14 at 03:37
Thanks for the tip! I realize using select and activate are pretty inefficient, but I don't think the performance gains would be that great here. I've made sure that all of the critical code (ie code that will be looped through thousands of times) doesn't contain any of these. Any of these references are remnants of the macro recorder, where I'm not yet sure yet how to remove them (e.g. creating new tabs) -- I'm only 2 weeks in to VBA! – Austin Wismer Jul 12 '14 at 03:55
You should consider bringing your new working code over to [Code Review](https://codereview.stackexchange.com/). – RubberDuck Jul 15 '14 at 03:35
Out of curiosity, what is the difference between Code Review and this? – Austin Wismer Jul 17 '14 at 18:33

VBA slowing down if sub procedure runs twice in same workbook?

1 Answers1