CODEWITHSUNDEEP
excelvba
Austin Wismer
Austin Wismer

Reputation: 281

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

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

Upvotes: 1

Views: 308

Answers (1)

Austin Wismer
Austin Wismer

Reputation: 281

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.

Upvotes: 2

Related Questions