Why does VBA run very slow?

Question

I have a large excel VBA project that reads in several files and generates a new excel spreadsheet with several tabs. When run with weekly data it takes around 7 minutes to run. When run with monthly data it is taking almost 18 hours to run. It used to take over 30 hours, but thanks to several post on here I have been able to optimize it a lot. I have tried to make the project modular, and I can select which portions of the program I want to run each time it is run. It is the full run that takes the 18 hours. I wrote in a logging capability to see what was taking so long, and have found a portion of the program that takes about 11 hours to run. The issue is, if I select only that portion of the program to run by itself, it only takes 3 minutes to run. During the full run this portion is run later in the full process, so there are several tabs already created before this one is done. When run alone, there are only the two tabs that this portion creates. I'm trying to figure out why there would be such a huge difference in the processing time between running it by itself, and running it in the full process.

I have added the module in question. It's probably not real pretty, but it works. Again, 11 hours when run in the full process and about three minutes when run alone against the same data set.

Thanks,

Sub Upcoming()

Dim Days As Integer
Dim gd_lastrow As Long

'If Logging = True Then
'    logIt ("    Create new sheet")
'End If

Sheets.Add after:=ActiveSheet
ActiveSheet.Name = "Coming Due"
Range("A1").Value = "IS Code"
Range("B1").Value = "Cage"
Range("C1").Value = "Contractor"
Range("D1").Value = "Contract Number"
Range("E1").Value = "Job #"
Range("F1").Value = "CLIN"
Range("G1").Value = "Due Date"
Range("H1").Value = "RDF"
Range("I1").Value = "Product"
Range("J1").Value = "Qty"
Range("K1").Value = "CA"
Rows("1:1").WrapText = True
Columns("B:B").ColumnWidth = 8
Columns("C:C").ColumnWidth = 46
Columns("D:D").ColumnWidth = 21
Columns("G:G").ColumnWidth = 18
Columns("H:H").ColumnWidth = 18
Columns("I:I").ColumnWidth = 15
Columns("F:F").ColumnWidth = 10
Columns("G:G").ColumnWidth = 21
Columns("K:K").ColumnWidth = 18

Columns("E:F").NumberFormat = "0000"
Columns("E:F").HorizontalAlignment = xlRight
Columns("G:H").NumberFormat = "[$-409]mmmm d, yyyy;@"

up_curline = 2
up_IS = ""

'Sheets("GD").Select
'gd_lastrow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1
gd_lastrow = (Sheets("GD").UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1

If myFileExists(myPath & "\GD.xlsx") Then
    If Logging = True Then
        logIt ("    Prep the GD for vLookup")
    End If
    Sheets("GD").Select
    If Range("BF6").Value = "" Then
        For i = 6 To gd_lastrow
            Range("BF" & i).Value = Range("F" & i).Value & Range("G" & i).Value & Range("T" & i)
            Range("BG" & i).Value = Abs(Range("P" & i))
            Range("BH" & i).Value = Range("F" & i).Value & Range("G" & i).Value & Range("U" & i)
            Range("BI" & i).Value = Abs(Range("P" & i))
        Next i
    End If
End If

'If Logging = True Then
'    logIt ("    Get upcoming schedules or RDFs")
'End If

Sheets("DWR").Select
up_lastRow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1

For i = 2 To up_lastRow  'Get upcoming RDF's
    Sheets("DWR").Select
    If Not IsError(Application.Match(Range("C" & i), Worksheets("CAR").Range("C:C"), 0)) Then  'Only get RDF's for the IS's in the CAR
        If Not IsError(Application.Match(Range("G" & i), Worksheets("CAR").Range("H:H"), 0)) Then  'Only get RDFs for active contracts
            If ((Range("K" & i) >= Now()) And (Range("K" & i) <= Now() + 90) And (Range("AE" & i) = "")) Or _
               ((Range("Q" & i) >= Now()) And (Range("Q" & i) <= Now() + 90) And (Range("AE" & i) = "")) Or _
               ((Range("AE" & i) >= Now()) And (Range("AE" & i) <= Now() + 90)) Then
                Worksheets("Coming Due").Range("A" & up_curline) = Range("C" & i)  'IS
                Worksheets("Coming Due").Range("B" & up_curline) = Range("E" & i)  ' Cage
                Worksheets("Coming Due").Range("C" & up_curline) = Range("D" & i)  'Contractor
                Worksheets("Coming Due").Range("D" & up_curline) = Range("G" & i)  ' Contract #
                Worksheets("Coming Due").Range("F" & up_curline) = Range("J" & i)  ' CLIN
                If (Range("K" & i) = 0) Then
                    Worksheets("Coming Due").Range("G" & up_curline) = Range("Q" & i)
                    Sheets("Coming Due").Select
                    Range("H" & up_curline).Select
                    'Sheets("Coming Due").Range("H" & up_curline).ThemeColor = xlThemeColorDark1
                    'Sheets("Coming Due").Range("H" & up_curline).TintAndShade = -0.249977111117893
                    With Selection.Interior
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                        .ThemeColor = xlThemeColorDark1
                        .TintAndShade = -0.249977111117893
                        .PatternTintAndShade = 0
                    End With
                    Sheets("DWR").Select
                Else
                    Worksheets("Coming Due").Range("G" & up_curline) = Range("K" & i)  ' Due Date
                End If
                If Worksheets("Coming Due").Range("H" & up_curline) <> "Service CLIN" Then
                    Worksheets("Coming Due").Range("H" & up_curline) = Range("AE" & i)  ' RDF
                End If
                If ((Worksheets("Coming Due").Range("H" & up_curline) = "") Or (Worksheets("Coming Due").Range("H" & up_curline)) = "Service CLIN") Then
                    Worksheets("Coming Due").Range("G" & up_curline).Style = "Neutral"
                Else
                    Worksheets("Coming Due").Range("H" & up_curline).Style = "Neutral"
                End If
                'Worksheets("Coming Due").Range("I" & up_curline) = Range("V" & i) ' Item
                If ((Range("N" & i) > 0) And (Range("N" & i) = Range("O" & i))) Then
                    Worksheets("Coming Due").Range("J" & up_curline) = "Shipped"
                Else
                    'Worksheets("Coming Due").Range("J" & up_curline) = Range("N" & i) - Range("O" & i)  ' Qty
                    On Error Resume Next
                    Err.Clear
                    Worksheets("Coming Due").Range("J" & up_curline) = Application.WorksheetFunction.VLookup(Worksheets("DWR").Range("G" & i).Value & format(Worksheets("DWR").Range("J" & i), "0000") & Worksheets("DWR").Range("K" & i), Worksheets("GD").Range("BF6:BG" & gd_lastrow), 2, 0)
                    If Err.Number <> 0 Then
                        Err.Clear
                        Worksheets("Coming Due").Range("J" & up_curline) = Application.WorksheetFunction.VLookup(Worksheets("DWR").Range("G" & i).Value & Worksheets("DWR").Range("J" & i) & Worksheets("DWR").Range("K" & i), Worksheets("GD").Range("BF6:BG" & gd_lastrow), 2, 0)
                        If Err.Number <> 0 Then
                            Err.Clear
                            Worksheets("Coming Due").Range("J" & up_curline) = Application.WorksheetFunction.VLookup(Worksheets("DWR").Range("G" & i).Value & format(Worksheets("DWR").Range("J" & i), "0000") & Worksheets("DWR").Range("K" & i), Worksheets("GD").Range("BH6:BI" & gd_lastrow), 2, 0)
                            If Err.Number <> 0 Then
                                Err.Clear
                                Worksheets("Coming Due").Range("J" & up_curline) = Application.WorksheetFunction.VLookup(Worksheets("DWR").Range("G" & i).Value & Worksheets("DWR").Range("J" & i) & Worksheets("DWR").Range("K" & i), Worksheets("GD").Range("BH6:BI" & gd_lastrow), 2, 0)
                                If Err.Number <> 0 Then
                                    If Logging = True Then
                                        logIt ("            VlookUp Still Not Found")
                                        logIt ("            " & Err.Number & ": " & Err.Description)
                                        logIt ("            i = " & i)
                                        logIt ("            Contract = " & Worksheets("DWR").Range("G" & i).Value)
                                        logIt ("            CLIN = " & format(Worksheets("DWR").Range("J" & i), "0000"))
                                        logIt ("            Schedule Date = " & Worksheets("DWR").Range("K" & i))
                                        logIt ("            Lookup Value = " & Worksheets("DWR").Range("G" & i).Value & format(Worksheets("DWR").Range("J" & i), "0000") & Worksheets("DWR").Range("K" & i))
                                    End If
                                End If
                            End If
                        End If
                    End If
                    On Error GoTo 0
                End If
                For o = 0 To 2000
                    If CDRLdata(o).contract = Worksheets("Coming Due").Range("D" & up_curline) Then
                        Worksheets("Coming Due").Range("E" & up_curline) = CDRLdata(o).job
                        Worksheets("Coming Due").Range("I" & up_curline) = CDRLdata(o).Product
                        Exit For
                    End If
                Next o
                up_curline = up_curline + 1
            End If
        End If
    End If
Next i

Sheets("Coming Due").Select
up_lastRow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1

'If Logging = True Then
'    logIt ("    Get service CLIN data")
'End If

Sheets("GD").Select  'Get service CLINs qty due
gd_lastrow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1

For j = 2 To up_lastRow
    If Worksheets("Coming Due").Range("J" & j) = 0 Then
        For i = 6 To gd_lastrow
            If ((Range("F" & i) = Worksheets("Coming Due").Range("D" & j)) And (Range("G" & i) = Worksheets("Coming Due").Range("F" & j)) And (Range("W" & i) = Worksheets("Coming Due").Range("G" & j))) Then
                If ((Range("H" & i) > 0) And (Range("H" & i) = Range("I" & i))) Then
                    Worksheets("Coming Due").Range("J" & j) = "Shipped"
                Else
                    Worksheets("Coming Due").Range("J" & j) = Range("H" & i) - Range("I" & i)
                End If
            End If
        Next i
    End If
Next j

For j = 2 To up_lastRow
    If Worksheets("Coming Due").Range("J" & j) = "Shipped" Then
        For i = 6 To gd_lastrow
            If ((Range("F" & i) = Worksheets("Coming Due").Range("D" & j)) And (Range("G" & i) = Worksheets("Coming Due").Range("F" & j)) And (Range("U" & i) = Worksheets("Coming Due").Range("G" & j))) Then
                If ((Range("N" & i) > 0) And (Range("N" & i) = Range("O" & i))) Then
                    Worksheets("Coming Due").Range("J" & j) = "Shipped"
                Else
                    Worksheets("Coming Due").Range("J" & j) = Range("N" & i) - Range("O" & i)
                End If
            End If
        Next i
    End If
Next j

' Add any comments

'If Logging = True Then
'    logIt ("    Add comments to the list")
'End If

Dim tCLIN As String

Sheets("Coming Due").Select
commenttext = ""

cd_lastrow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1

For r = 2 To cd_lastrow
    For p = 0 To 2000
        If CDRLdata(p).company = "" Then
            Exit For
        End If

        ' Contract level

        If ((CDRLdata(p).contract = Worksheets("Coming Due").Range("D" & r)) And (CDRLdata(p).CoNotes <> "")) Then
            commenttext = CDRLdata(p).contract & ": " & CDRLdata(p).CoNotes
            temp2 = "D" & r
            Set mycomment = Range(temp2).Comment
            If mycomment Is Nothing Then
                Range(temp2).AddComment
                Range(temp2).Comment.Visible = False
                Range(temp2).Comment.Text commenttext
                Range(temp2).Comment.Shape.TextFrame.AutoSize = True
            End If
        End If

        ' CLIN Level

        If CDRLdata(p).contract = Worksheets("Coming Due").Range("D" & r) Then
            If Len(Worksheets("Coming Due").Range("F" & r)) = 1 Then
                tCLIN = "000" & Worksheets("Coming Due").Range("F" & r)
            Else
                If Len(Worksheets("Coming Due").Range("F" & r)) = 2 Then
                    tCLIN = "00" & Worksheets("Coming Due").Range("F" & r)
                Else
                    If Len(Worksheets("Coming Due").Range("F" & r)) = 3 Then
                        tCLIN = "0" & Worksheets("Coming Due").Range("F" & r)
                    Else
                        tCLIN = Worksheets("Coming Due").Range("F" & r)
                    End If
                End If
            End If

            If ((CDRLdata(p).CLIN = tCLIN) And (tCLIN <> "")) Then
                If CDRLdata(p).CdNotes <> "" Then
                    commenttext = CDRLdata(p).contract & " CLIN " & CDRLdata(p).CLIN & ": "
                    If CDRLdata(p).di <> "" Then
                        commenttext = commenttext & CDRLdata(p).di & " "
                    End If
                    commenttext = commenttext & CDRLdata(p).CdNotes
                    For q = p + 1 To 2000
                        If ((CDRLdata(q).contract = Worksheets("Coming Due").Range("D" & r)) And (CDRLdata(q).CLIN = Worksheets("Coming Due").Range("F" & r)) And (CDRLdata(q).CdNotes <> "")) Then
                            commenttext = commenttext & "  " & " CLIN " & CDRLdata(q).CLIN & ": "
                            If CDRLdata(q).di <> "" Then
                                commenttext = commenttext & CDRLdata(q).di & " "
                            End If
                            commenttext = commenttext & CDRLdata(q).CdNotes
                        End If
                    Next q
                    temp2 = "F" & r
                    Set mycomment = Range(temp2).Comment
                    If mycomment Is Nothing Then
                        Range(temp2).AddComment
                        Range(temp2).Comment.Visible = False
                        Range(temp2).Comment.Text commenttext
                        Range(temp2).Comment.Shape.TextFrame.AutoSize = True
                    End If
                    Exit For
                End If
            End If
        End If
    Next p
Next r

'If Logging = True Then
'    logIt ("    Format comments")
'End If

Comments_Tom

'If Logging = True Then
'    logIt ("    Sort table by IS, Cage, Due date, Contract and CLIN")
'End If

Sheets("Coming Due").Select

up_lastRow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1

For i = 2 To up_lastRow
    If Range("H" & i) = "" Then
        Range("M" & i) = Range("G" & i)
    Else
        If Range("H" & i) = "Service CLIN" Then
            Range("M" & i) = Range("G" & i)
        Else
            Range("M" & i) = Range("H" & i)
        End If
    End If
Next

For i = 2 To up_lastRow
    For p = 0 To 2000
        ' Get CA Name
        If CDRLdata(p).contract = Worksheets("Coming Due").Range("D" & i) Then
            If CDRLdata(p).Position1 = "Contract Administrator" Then
                Range("K" & i) = CDRLdata(p).Name1
            Else
                If CDRLdata(p).Position2 = "Contract Administrator" Then
                    Range("K" & i) = CDRLdata(p).Name2
                Else
                    If CDRLdata(p).Position3 = "Contract Administrator" Then
                        Range("K" & i) = CDRLdata(p).Name3
                    End If
                End If
            End If
            Exit For
        End If
    Next p
Next i

'sort by IS, Cage, Due date, Contract, CLIN

Range("A2:M" & up_lastRow).Select
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Add Key:=Range( _
    "A2:A" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Add Key:=Range( _
    "B2:B" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortTextAsNumbers
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Add Key:=Range( _
    "M2:M" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Add Key:=Range( _
    "D2:D" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
ActiveWorkbook.Worksheets("Coming Due").Sort.SortFields.Add Key:=Range( _
    "F2:F" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
With ActiveWorkbook.Worksheets("Coming Due").Sort
    .SetRange Range("A1:M" & up_lastRow)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

ActiveWorkbook.Save

' enter 30/60/90 day group headers

If Logging = True Then
    logIt ("    Enter 30/60/90 day headers")
End If

Sheets("Coming Due").Select
Range("A2").Select

up_curline = 2
up_IS = Range("A2")
up_cage = Range("B2")
up_Contract = Range("C2")
up_Due = Range("G2")
up_RDF = Range("H2")
up_Due = 0
up_RDF = 0

Rows("2:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
up_lastRow = up_lastRow + 3
up_curline = up_curline + 3

If ((Range("G" & up_curline) <= Now() + 30) And (Range("H" & up_curline) = "")) Then
    Range("D" & up_curline - 2).Value = "Due within 30 days"
    Days = 30
Else
    If ((Range("G" & up_curline) <= Now() + 60) And (Range("H" & up_curline) = "")) Then
        Range("D" & up_curline - 2).Value = "Due within 60 days"
        Days = 60
    Else
        If Range("H" & up_curline) = "" Then
            Range("D" & up_curline - 2).Value = "Due within 90 days"
            Days = 90
        End If
    End If
End If
If (Range("H" & up_curline) <> "") Then
    If Range("H" & up_curline) <= Now() + 30 Then
        Range("D" & up_curline - 2).Value = "Due within 30 days"
        Days = 30
    Else
        If Range("H" & up_curline) <= Now() + 60 Then
            Range("D" & up_curline - 2).Value = "Due within 60 days"
            Days = 60
        Else
            Range("D" & up_curline - 2).Value = "Due within 90 days"
            Days = 90
        End If
    End If
End If

i = up_curline
Do Until IsEmpty(Cells(i, 1))
    If Range("B" & i) <> up_cage Then
        up_cage = Range("B" & i)
        Rows(i & ":" & i + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        up_lastRow = up_lastRow + 3
        i = i + 3
        If ((Range("G" & i) <= Now() + 30) And ((Range("H" & i) = "")) Or _
            (((Range("H" & i) <> "")) And (Range("H" & i) <= Now() + 30))) Then
            Range("D" & i - 2).Value = "Due within 30 days"
            Days = 30
        Else
            If ((Range("G" & i) <= Now() + 60) And ((Range("H" & i) = "")) Or _
                (((Range("H" & i) <> "")) And (Range("H" & i) <= Now() + 60))) Then
                Range("D" & i - 2).Value = "Due within 60 days"
                Days = 60
            Else
                Range("D" & i - 2).Value = "Due within 90 days"
                Days = 90
            End If
        End If
    End If
    If (Days = 30) And _
       (((Range("G" & i) > Now() + 30) And (Range("G" & i) <= Now + 60) And (Range("H" & i) = "")) Or _
       ((Range("H" & i) > Now() + 30) And (Range("H" & i) <= Now + 60) And (Range("H" & i) <> ""))) Then
        Days = 60
        Rows(i & ":" & i + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        up_lastRow = up_lastRow + 3
        i = i + 3
        Range("D" & i - 2).Value = "Due within 60 days"
    End If
    If (Days = 30) And _
       (((Range("G" & i) > Now() + 60) And (Range("G" & i) <= Now + 90) And (Range("H" & i) = "")) Or _
       ((Range("H" & i) > Now() + 60) And (Range("H" & i) <= Now + 90) And (Range("H" & i) <> ""))) Then
        Days = 90
        Rows(i & ":" & i + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        up_lastRow = up_lastRow + 3
        i = i + 3
        Range("D" & i - 2).Value = "Due within 90 days"
    End If
    If (Days = 60) And _
       (((Range("G" & i) > Now() + 60) And (Range("G" & i) <= Now + 90) And (Range("H" & i) = "")) Or _
       ((Range("H" & i) > Now() + 60) And (Range("H" & i) <= Now + 90) And (Range("H" & i) <> ""))) Then
        Days = 90
        Rows(i & ":" & i + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        up_lastRow = up_lastRow + 3
        i = i + 3
        Range("D" & i - 2).Value = "Due within 90 days"
    End If
    i = i + 1
Loop

Columns("M:M").Delete

For i = 5 To up_lastRow
    If Left(Range("D" & i), 10) = "Due within" Then
        Range("G" & i - 1 & ":H" & i + 1).Style = "Normal"
    End If
Next

Sheets("Coming Due").Select
ActiveCell.ClearComments
Range("A2").Select
ActiveWindow.FreezePanes = True
ActiveSheet.Name = "30-60-90 By Date"
up_lastRow = (ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row) - 1
Range("A1:K" & up_lastRow).Borders.LineStyle = xlContinuous

ActiveWorkbook.Save

' Create the 30-60-90 by Contract Tab

If Logging = True Then
    logIt ("Begin Upcoming By Contract")
End If

Dim curCage As String
Dim curContract As String

Range("A1:K" & up_lastRow).Select
Selection.Copy
Sheets.Add
ActiveSheet.Name = "30-60-90 By Contract"
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
If Logging = True Then
    logIt ("    Begin Sorting By Contract")
End If
ActiveWorkbook.Worksheets("30-60-90 By Contract").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("30-60-90 By Contract").Sort.SortFields.Add Key:= _
    Range("B5:B" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
    :=xlSortNormal
ActiveWorkbook.Worksheets("30-60-90 By Contract").Sort.SortFields.Add Key:= _
    Range("D5:D" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
    :=xlSortNormal
ActiveWorkbook.Worksheets("30-60-90 By Contract").Sort.SortFields.Add Key:= _
    Range("G5:G" & up_lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
    :=xlSortNormal
With ActiveWorkbook.Worksheets("30-60-90 By Contract").Sort
    .SetRange Range("A5:K" & up_lastRow)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Rows("3:4").Delete Shift:=xlUp
If Logging = True Then
    logIt ("    Begin Deleting Blank Rows")
End If
For i = up_lastRow - 2 To 1 Step -1
    If Range("A" & i).Value = "" Then
        Rows(i & ":" & i).Delete Shift:=xlUp
    Else
        up_lastRow = i
        Exit For
    End If
    If ((i Mod 200) = 0) Then
        If Logging = True Then
            logIt ("    Line =" & i)
        End If
    End If
Next i
Range("A2").Select
ActiveWindow.FreezePanes = True
curCage = Range("B3").Value
curContract = Range("D3").Value
j = 4
If Logging = True Then
    logIt ("    Begin Looking For New CAGE or Contract Number")
End If

While Range("A" & j).Value <> ""
    If Range("B" & j).Value <> curCage Then
        curCage = Range("B" & j).Value
        curContract = Range("D" & j).Value
        Rows(j & ":" & j + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        j = j + 2
    End If
    If Range("D" & j).Value <> curContract Then
        curContract = Range("D" & j).Value
        Rows(j & ":" & j).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        j = j + 1
    End If
    j = j + 1
    If ((j Mod 200) = 0) Then
        If Logging = True Then
            logIt ("    Line =" & j)
        End If
    End If
Wend
End Sub

We can't help you without seeing the code that's running slowly. Though I'd make an educated guess that it's doing something that triggers Excel to perform an entire workbook recalculation or invalidating something displayed on-screen. Does it run as slowly on Excel 2010? (Office 2010 was the last version to use faster 2D painting) — Dai, May 09 '18 at 02:42
Also, you could rewrite the code in C# or even C++ using the Office COM Automation APIs (VSTO) if it turns out the bottleneck is in the VBA code itself rather than inside Excel. — Dai, May 09 '18 at 02:43
Finally, have you profiled your code (e.g. using `GetTickCount`) to determine exactly what's going on? And have you eliminated any algorithmic or design issues (e.g. algorithms with `O(n^2)` time complexity?) — Dai, May 09 '18 at 02:44
Maybe "purging memory", as in [this answer](https://stackoverflow.com/a/33828800/4717755) — PeterT, May 09 '18 at 02:44
Thanks for the quick response. The part about the workbook recalc sounds interesting, and I'll look at the purging memory. I'm not doing any serious math. It's primarily reformatting data into different views. So it is sorting, and then deleting lots of lines, and it deletes some columns. I've read that these can be slow processes, but it doesn't make sense that it would be 11 hours difference. — BlueStallion, May 09 '18 at 02:50
I just looked at the purging memory answer. I had seen that one before and am saving the file periodically. It was one of my earlier optimizations, and it does help. — BlueStallion, May 09 '18 at 02:55
The short answer is: use the correct tool for the job. If this tool is just formatting data into reports, use a tool that can do that faster. — Nick.Mc, May 09 '18 at 03:11
There are lots of ways to make VBA run faster: turn off screen updating, turn off events, turn off sheet calculation, don't use `.Select`, use autofilter rather than loops if you can, etc. Can you please provide the code that is running slowly since you narrowed it down? — Joseph, May 09 '18 at 04:14
You have a lot of reading from and writing to individual cells. One way to speed up VBA is to read and write data in arrays. Build up a VBA array and write it to a range in a single line of code rather than looping through a range, writing values one by one. The code is a bit much to look at in detail. You might consider using [codereview.se] rather than Stack Overflow. — John Coleman, May 09 '18 at 13:33
Thanks for all the suggestions Joseph. I have done most of those except turning off autocalculation. I have just added that to the module and will test it tonight. From running some tests on weekly data it did bring down the times, but the big test will be against the monthly data. I'll post my results once it's done. — BlueStallion, May 09 '18 at 19:28
Definitely one for [Code Review](https://codereview.stackexchange.com/) rather than here. Going with the comment from @JohnColeman - you could significantly reduce the time by not reading/writing to the sheet so much. Why can't we select Code Review in: "This question belongs on another site in the Stack Exchange network" when voting to close? — Darren Bartrup-Cook, May 11 '18 at 12:36
Also declare all your variables (Option Explicit at the top!) - `up_curline`, `up_IS`, `myPath`, `Logging`, `i`, `o`, `j`, `r`, `p`, `q`, `up_lastrow`, `CDRLData`, `commenttext`, `cd_lastrow`, `temp2`, `mycomment` to name a few. If you add to CodeReview also include the other procedures - `logit`, `myFileExists` and any others I've missed. — Darren Bartrup-Cook, May 11 '18 at 12:51

score 0 · Answer 1 · answered May 09 '18 at 06:02

the VBA is kind of like Java which runs on JVM it is not really the CPU that does run it. for example, consider the game speed when you would emulate PS3 on PC/Mac rather than using the real device (in short very slow).

what mean's VBA is already very slow and now your code does run on Excel and that will further slow everything since it will wait for Excel view/update.

my choice would be to rewrite your code using Qt and QtXlsxWriter. although changing from VBA to C++ was a great step for me but the Qt libraries where/are even more clear to understand as VBA.

another option would be to provide your code so we see what is the problem but it looks like that is not an option ;-)

without the code's I think it has to do with VBA waiting for Excel update

score 0 · Accepted Answer · answered May 11 '18 at 11:25

I have pretty much solved my problem, but still do not have an answer to my question. I now have the monthly run being completed in less than 4 hours, and still see where other optimizations can be made. I primarily made three changes. First, I put in Application.Calculation = xlCalculationManual at the beginning of the module that was taking so long, and set it back to automatic at the end of the module. This cut the 11 hours down to around 4 to 5 hours. I had read a lot on optimization, but the comment above was the first time I had heard of this. Next I moved this module up to the beginning of the run. Recall that running this module later in the full run took 11 hours, but when run alone, it only took around three minutes. When run as the first module, in the full run it just takes three to four minutes. And finally, I rewrote the module to use 2D array instead of inserting and deleting rows and columns in the worksheets. The module now takes around 1 minute. From 11 + hours to 1 minute is pretty good I'm thinking. But the question is still there. Why did moving the module from later in the run to first cause such a big difference, especially when recalc was set to manual. Is it memory management? Is it ????? I dunno, but I'm very happy with the results.

Why does VBA run very slow?

2 Answers2