My VBA code takes far too long, any suggestions on how to shorten the time? For Loop

Question

My code is designed to open a file, copy the contents of the file, paste it into a working file with formulas. The formulas identify whether a row should be ignored. The code then goes through each row and copies over the row with "ignore" into a different tab and then deletes the row. The code then looks to see if "INV NOT FOUND", if the row has this designation it will then copy the row in to a new workbook and once it has gone through all of the rows, it closes and saves the new workbook. I have some files that are 5k+ rows and this takes far too long.

I am not really sure how else to code the loop.

Option Explicit

Sub RawData()
Dim CurrentDate As String
Dim PB As String
Dim ReturnsCheck As String
Dim Filename As String
Dim MyRange As String
Dim aWB As Workbook
Dim tWB As Workbook, newSheet As Worksheet
Dim MissingInvCount As Long
Dim rng As Range
Dim cell As Range
Dim search As String

Set tWB = ThisWorkbook

CurrentDate = Range("C6")
PB = Range("C8")

Application.EnableCancelKey = xlDisabled

Worksheets("data table").Visible = True

If tWB.Worksheets("home").Range("PB") = "Citi" Then
    Worksheets("sort area").Visible = True
ElseIf tWB.Worksheets("home").Range("PB") = "Pershing" Then
    Worksheets("pershing").Visible = True
ElseIf tWB.Worksheets("home").Range("PB") = "JPM" Then
    Worksheets("jpm").Visible = True
ElseIf tWB.Worksheets("home").Range("PB") = "Goldman Sachs" Then
    Worksheets("gs").Visible = True
ElseIf tWB.Worksheets("home").Range("PB") = "Morgan Stanley" Then
    Worksheets("ms").Visible = True

End If

'Opens Raw file
    Workbooks.Open Filename:="G:\CMG\DCM\Operations\Monthly Cycle\Monthly Transaction Upload\" & Range("PB") & "\" & Format(Range("CurrentDate"), "yyyy") & "\Raw Files\" & "Raw File - " & Range("PB") & " " & Format(Range("CurrentDate"), "mmddyy") & ".csv"


ActiveWorkbook.Activate
Set aWB = ActiveWorkbook

If tWB.Worksheets("home").Range("PB") = "Citi" Then
    aWB.Activate
       Range("A1", Range("CZ" & Rows.Count).End(xlUp)).Copy
    tWB.Worksheets("sort area").Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
ElseIf tWB.Worksheets("home").Range("PB") = "Pershing" Then
    aWB.Activate
       Range("A1", Range("U" & Rows.Count).End(xlUp)).Copy
    tWB.Worksheets("pershing").Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
ElseIf tWB.Worksheets("home").Range("PB") = "JPM" Then
    aWB.Activate
       Range("A1", Range("AD" & Rows.Count).End(xlUp)).Copy
    tWB.Worksheets("jpm").Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
ElseIf tWB.Worksheets("home").Range("PB") = "Goldman Sachs" Then
    aWB.Activate
       Range("A1", Range("V" & Rows.Count).End(xlUp)).Copy
    tWB.Worksheets("gs").Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
ElseIf tWB.Worksheets("home").Range("PB") = "Morgan Stanley" Then
    aWB.Activate
       Range("A1", Range("L" & Rows.Count).End(xlUp)).Copy
    tWB.Worksheets("ms").Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
End If

'Closes Raw File w/o saving
    aWB.Close SaveChanges:=False

'Copy Formulas down
Dim Lastrow As Long

If tWB.Worksheets("home").Range("PB") = "Citi" Then
    Worksheets("sort area").Activate
    Lastrow = Range("A" & Rows.Count).End(xlUp).Row
    Range("DB2:FN" & Lastrow).FillDown
ElseIf Range("PB") = "Pershing" Then
    Worksheets("pershing").Activate
    Lastrow = Range("B" & Rows.Count).End(xlUp).Row
    Range("W2:BO" & Lastrow).FillDown
ElseIf Range("PB") = "JPM" Then
    Worksheets("jpm").Activate
    Lastrow = Range("A" & Rows.Count).End(xlUp).Row
    Range("AI2:CU" & Lastrow).FillDown
ElseIf Range("PB") = "Goldman Sachs" Then
    Worksheets("gs").Activate
    Lastrow = Range("A" & Rows.Count).End(xlUp).Row
    Range("X2:CJ" & Lastrow).FillDown
ElseIf Range("PB") = "Morgan Stanley" Then
    Worksheets("ms").Activate
    Lastrow = Range("A" & Rows.Count).End(xlUp).Row
    Range("N2:BZ" & Lastrow).FillDown

End If

'Remove ignored lines & Idenitifies missing investments

Dim n As Integer
Dim nLastRow As Long
Dim nFirstRow As Long
Dim r As Range


    Set r = ActiveSheet.UsedRange
    nLastRow = Lastrow - 1
    nFirstRow = 2


Dim i As Long: i = 1

With ActiveSheet
    On Error Resume Next
    Application.ScreenUpdating = False

    If tWB.Worksheets("home").Range("PB") = "Citi" Then

        For n = nLastRow To nFirstRow Step -1
            If .Cells(n, "DB") = "IGNORE" Then
                .Cells(n, "DB").EntireRow.Copy
                 Worksheets("ignore").Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                 Application.CutCopyMode = False
                .Cells(n, "DB").EntireRow.Delete
                i = i + 1
            End If
        Next

    ElseIf Range("PB") = "Pershing" Then

        For n = nLastRow To nFirstRow Step -1
            If .Cells(n, "W") = "IGNORE" Then
                .Cells(n, "W").EntireRow.Copy
                 Worksheets("ignore").Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                 Application.CutCopyMode = False
                .Cells(n, "W").EntireRow.Delete
                i = i + 1
            End If
        Next

    ElseIf Range("PB") = "JPM" Then

        For n = nLastRow To nFirstRow Step -1
            If .Cells(n, "AI") = "IGNORE" Then
                .Cells(n, "AI").EntireRow.Copy
                 Worksheets("ignore").Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                 Application.CutCopyMode = False
                .Cells(n, "AI").EntireRow.Delete
                i = i + 1
            End If
        Next

    ElseIf Range("PB") = "Goldman Sachs" Then

        For n = nLastRow To nFirstRow Step -1
            If .Cells(n, "X") = "IGNORE" Then
                .Cells(n, "X").EntireRow.Copy
                 Worksheets("ignore").Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                 Application.CutCopyMode = False
                .Cells(n, "X").EntireRow.Delete
                i = i + 1
            End If
        Next

    ElseIf Range("PB") = "Morgan Stanley" Then

        For n = nLastRow To nFirstRow Step -1
            If .Cells(n, "N") = "IGNORE" Then
                .Cells(n, "N").EntireRow.Copy
                 Worksheets("ignore").Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                 Application.CutCopyMode = False
                .Cells(n, "N").EntireRow.Delete
                i = i + 1
            End If
        Next

    End If
End With

'Sort Ignore tab
Worksheets("ignore").Activate
Lastrow = Cells(Rows.Count, 2).End(xlUp).Row

If tWB.Worksheets("home").Range("PB") = "Citi" Then
    Range("A1:FG" & Lastrow).SORT key1:=Range("DE1:DE" & Lastrow), _
     order1:=xlAscending, Header:=xlNo

ElseIf Range("PB") = "Pershing" Then
    Range("A1:BO" & Lastrow).SORT key1:=Range("Z1:Z" & Lastrow), _
     order1:=xlAscending, Header:=xlNo

ElseIf Range("PB") = "JPM" Then
    Range("A1:CU" & Lastrow).SORT key1:=Range("AL1:AL" & Lastrow), _
     order1:=xlAscending, Header:=xlNo

ElseIf Range("PB") = "Goldman Sachs" Then
    Range("A1:CJ" & Lastrow).SORT key1:=Range("AA1:AA" & Lastrow), _
     order1:=xlAscending, Header:=xlNo

ElseIf Range("PB") = "Morgan Stanley" Then
    Range("A1:BZ" & Lastrow).SORT key1:=Range("Q1:Q" & Lastrow), _
     order1:=xlAscending, Header:=xlNo

End If

'Missing investments

If tWB.Worksheets("home").Range("PB") = "Citi" Then

Worksheets("sort area").Activate
Set rng = ActiveSheet.Range("DF1:DF" & Lastrow)
search = "INV NOT FOUND"
Set cell = rng.Find(What:=search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

    If cell Is Nothing Then
        MsgBox ("There are no missing investments.")
    Else
        Set newSheet = ThisWorkbook.Sheets.Add
        Worksheets("sort area").Activate
        i = 1

        With ActiveSheet
        On Error Resume Next
        Application.ScreenUpdating = False
            For n = nLastRow To nFirstRow Step -1
                If .Cells(n, "DF") = "INV NOT FOUND" Then
                    .Cells(n, "DF").EntireRow.Copy
                     newSheet.Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                     Application.CutCopyMode = False
                     .Cells(n, "DF").EntireRow.Delete
                    i = i + 1
                End If
            Next
        End With
        MissingInvCount = i - 1
    End If
End If

If Range("PB") = "Pershing" Then

Worksheets("pershing").Activate
Set rng = ActiveSheet.Range("AA1:AA" & Lastrow)
search = "INV NOT FOUND"
Set cell = rng.Find(What:=search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

    If cell Is Nothing Then
        MsgBox ("There are no missing investments.")
    Else
        Set newSheet = ThisWorkbook.Sheets.Add
        Worksheets("pershing").Activate
        i = 1

        With ActiveSheet
        On Error Resume Next
        Application.ScreenUpdating = False
            For n = nLastRow To nFirstRow Step -1
                If .Cells(n, "AA") = "INV NOT FOUND" Then
                    .Cells(n, "AA").EntireRow.Copy
                     newSheet.Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                     Application.CutCopyMode = False
                     .Cells(n, "AA").EntireRow.Delete
                    i = i + 1
                End If
            Next
        End With
        MissingInvCount = i - 1
    End If
End If

If Range("PB") = "JPM" Then

Worksheets("jpm").Activate
Set rng = ActiveSheet.Range("AM1:AM" & Lastrow)
search = "INV NOT FOUND"
Set cell = rng.Find(What:=search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

    If cell Is Nothing Then
        MsgBox ("There are no missing investments.")
    Else
        Set newSheet = ThisWorkbook.Sheets.Add
        Worksheets("jpm").Activate
        i = 1

        With ActiveSheet
        On Error Resume Next
        Application.ScreenUpdating = False
            For n = nLastRow To nFirstRow Step -1
                If .Cells(n, "AM") = "INV NOT FOUND" Then
                    .Cells(n, "AM").EntireRow.Copy
                     newSheet.Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                     Application.CutCopyMode = False
                     .Cells(n, "AM").EntireRow.Delete
                    i = i + 1
                End If
            Next
        End With
        MissingInvCount = i - 1
    End If
End If

If Range("PB") = "Goldman Sachs" Then

Worksheets("gs").Activate
Set rng = ActiveSheet.Range("AB1:AB" & Lastrow)
search = "INV NOT FOUND"
Set cell = rng.Find(What:=search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

    If cell Is Nothing Then
        MsgBox ("There are no missing investments.")
    Else
        Set newSheet = ThisWorkbook.Sheets.Add
        Worksheets("gs").Activate
        i = 1

        With ActiveSheet
        On Error Resume Next
        Application.ScreenUpdating = False
            For n = nLastRow To nFirstRow Step -1
                If .Cells(n, "AB") = "INV NOT FOUND" Then
                    .Cells(n, "AB").EntireRow.Copy
                     newSheet.Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                     Application.CutCopyMode = False
                     .Cells(n, "AB").EntireRow.Delete
                    i = i + 1
                End If
            Next
        End With
        MissingInvCount = i - 1
    End If
End If

If Range("PB") = "Morgan Stanley" Then

Worksheets("ms").Activate
Set rng = ActiveSheet.Range("R1:R" & Lastrow)
search = "INV NOT FOUND"
Set cell = rng.Find(What:=search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

    If cell Is Nothing Then
        MsgBox ("There are no missing investments.")
    Else
        Set newSheet = ThisWorkbook.Sheets.Add
        Worksheets("ms").Activate
        i = 1

        With ActiveSheet
        On Error Resume Next
        Application.ScreenUpdating = False
            For n = nLastRow To nFirstRow Step -1
                If .Cells(n, "R") = "INV NOT FOUND" Then
                    .Cells(n, "R").EntireRow.Copy
                     newSheet.Cells(i, "A").PasteSpecial Paste:=xlPasteValues
                     Application.CutCopyMode = False
                     .Cells(n, "R").EntireRow.Delete
                    i = i + 1
                End If
            Next
        End With
        MissingInvCount = i - 1
    End If
End If

If MissingInvCount <> 0 Then
MsgBox ("There are " & MissingInvCount & " missing investments.")
End If

'Sort Missing Investments tab
If MissingInvCount <> 0 Then

    newSheet.Activate
    Lastrow = Cells(Rows.Count, 2).End(xlUp).Row

    If tWB.Worksheets("home").Range("PB") = "Citi" Then
        Range("A1:FN" & Lastrow).SORT key1:=Range("DC1:DC" & Lastrow), _
            order1:=xlAscending, Header:=xlNo
        Columns("DD:FN").EntireColumn.Delete

    ElseIf tWB.Worksheets("home").Range("PB") = "Pershing" Then
        Range("A1:CI" & Lastrow).SORT key1:=Range("X1:X" & Lastrow), _
            order1:=xlAscending, Header:=xlNo
        Columns("Y:FN").EntireColumn.Delete

    ElseIf tWB.Worksheets("home").Range("PB") = "JPM" Then
        Range("A1:CU" & Lastrow).SORT key1:=Range("AJ1:AJ" & Lastrow), _
            order1:=xlAscending, Header:=xlNo
        Columns("AK:CU").EntireColumn.Delete

    ElseIf tWB.Worksheets("home").Range("PB") = "Goldman Sachs" Then
     Range("A1:CJ" & Lastrow).SORT key1:=Range("Y1:Y" & Lastrow), _
         order1:=xlAscending, Header:=xlNo
     Columns("Z:CJ").EntireColumn.Delete

    ElseIf tWB.Worksheets("home").Range("PB") = "Morgan Stanley" Then
     Range("A1:BZ" & Lastrow).SORT key1:=Range("O1:O" & Lastrow), _
         order1:=xlAscending, Header:=xlNo
     Columns("P:BZ").EntireColumn.Delete

    End If

    'Save flat file
    Dim strFullname As String
    Dim strFullname2 As String

    strFullname = "G:\CMG\DCM\Operations\Monthly Cycle\Monthly Transaction Upload\" & Range("PB") & "\" & Format(Range("CurrentDate"), "yyyy") & "\Investments Pending Creation\" & Range("PB") & " " & Format(Range("CurrentDate"), "mmddyy") & ".csv"
    strFullname2 = "G:\CMG\DCM\Operations\Monthly Cycle\Monthly Transaction Upload\" & Range("PB") & "\" & Format(Range("CurrentDate"), "yyyy") & "\Ignored\" & Range("PB") & " " & Format(Range("CurrentDate"), "mmddyy") & ".csv"

    Application.DisplayAlerts = False

    ThisWorkbook.ActiveSheet.Move
    ActiveWorkbook.SaveAs Filename:=strFullname, FileFormat:=xlCSV, CreateBackup:=True
    ActiveWorkbook.Close

    ThisWorkbook.Worksheets("ignore").Copy
    ActiveWorkbook.SaveAs Filename:=strFullname2, FileFormat:=xlCSV, CreateBackup:=True
    ActiveWorkbook.Close

End If

Application.DisplayAlerts = True

Application.ScreenUpdating = True

Sheets("home").Activate

End Sub

i would like to code to finish in under 5 minutes if possible.

A good place to start would be to study and implement [this](https://stackoverflow.com/q/10714251/9758194) post. Also, don't iterate over `Range` object but work through memory (read/write arrays, dictionaries and collections). Furthermore, if this is working code, you should really be posting this at [Code Review](https://codereview.stackexchange.com/) — JvdV, Nov 01 '19 at 22:56
There's a lot of repetition such as reading the value from `tWB.Worksheets("home").Range("PB")` - you can instead read it into a variable once, right at the top of your sub — Tim Williams, Nov 01 '19 at 23:00
In a project I’m working on, @TinMan did a great job working with ranges using a super fast class. Check this [link](https://codereview.stackexchange.com/a/226296/171419) — Ricardo Diaz, Nov 01 '19 at 23:01
@TimWilliams When you say, "read it into a variable once", what do you mean? within the home worksheet, the user has multiple options to chose from a drop down menu (i.e. JPM, GS, Morgan Stanley, Citi, Pershing). That cell has been named PB and that's what drives what part of the code should run. Is there a better way to do that? Can i add Set PB = tWB.Worksheets("home").Range("PB") and then replace that with PB - will that work? — Natasha Leon, Nov 04 '19 at 22:13
I mean like `Dim pb As String: pb = tWB.Worksheets("home").Range("PB").Value` then just refer to `pb` instead of going to the worksheet every time. — Tim Williams, Nov 04 '19 at 22:45
On a more general note - a lot of your code is essentially repeated, with some changes according to the selected "PB" value. If you had a lookup table ( eg PB Value >> worksheet name) you could use that to drive your actions and reduce the total amount of code you need to maintain. A new company would then just be a new row in your lookup table. — Tim Williams, Nov 04 '19 at 23:11

score 0 · Answer 1 · answered Nov 01 '19 at 22:55

Just before (or immediately after) this statement:

Set tWB = ThisWorkbook

add this:

  With Application
    .CalculateFull
    .EnableEvents = False
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With

Then at the end, replace these two lines:

Application.DisplayAlerts = True
Application.ScreenUpdating = True

with:

  With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
  End With

My VBA code takes far too long, any suggestions on how to shorten the time? For Loop

1 Answers1