How to optimize multiple loops in VBA code within Excel

Question

I am not a very efficient vba coder, but I can brute force my way through something. I am trying to optimize this code to have it run more quickly. I would imagine it should be possible to combine the loops somehow, but I am not exactly sure where to start since the Sheets are within the formulas. Any assistance would be greatly appreciated.

Sub Import()

Application.EnableEvents = False 'This stops the background codes on the sheets from activating (smoothens out the process).
Application.ScreenUpdating = False 'Stops the screen from switching back and forth between the Input and the Master
Application.DisplayAlerts = False

If InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE1", vbTextCompare) <> 0 Then
            Sheets("SHEET2").Activate
            Range("A4").Select
ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE2", vbTextCompare) <> 0 Then
            Sheets("SHEET2").Activate
            Range("A4").Select
ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE3", vbTextCompare) <> 0 Then
            Sheets("SHEET2").Activate
            Range("A4").Select
ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "All", vbTextCompare) <> 0 Then
            Sheets("SHEET2").Activate
            Range("A4").Select
Else:
    Sheets("SHEET1").Columns("KA:KC").Hidden = True
    Sheets("SHEET2").Columns("KA:KC").Hidden = True
    Sheets("SHEET3").Columns("KA:KC").Hidden = True
    Sheets("SHEET4").Columns("KA:KC").Hidden = True
    MsgBox "Doesn't exist for these locations"
    Exit Sub
End If
    Sheets("SHEET1").Columns("KA:KC").Hidden = False
    Sheets("SHEET2").Columns("KA:KC").Hidden = False
    Sheets("SHEET3").Columns("KA:KC").Hidden = False
    Sheets("SHEET4").Columns("KA:KC").Hidden = False

`'This removes the old DATASHEET tab from the model before starting (if it exists)
Dim SummaryWB As Workbook
Dim vrtSelectedItem As Variant
  For Each Sheet In ActiveWorkbook.Worksheets
     If Sheet.Name = "DATASHEET" Then
          Sheet.Delete
     End If
  Next Sheet

''' The below opens the RRS file from the file path defined
Workbooks.Open Filename:="\\Template_Current.xlsx"


'' This just pauses the operating for 1 second to allow the file to be opened seamlessly, can probably be removed.
Application.Wait Now + #12:00:01 AM#


'' This copies the Data from the RRS file and moves it into the CPM model in a new tab, and renames it.
'' It then closes the Source file.

Sheets("Data").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Report.xlsm").Activate
Sheets("YAdd").Select
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
ActiveSheet.Select
ActiveSheet.Name = "DATASHEET"
Windows("Template_Current.xlsx").Activate
Sheets("List View").Select
Range("D3").Select
Selection.Copy
Windows("Report.xlsm").Activate
Sheets("DATASHEET").Select
Range("W1").Select
ActiveSheet.Paste
Windows("Template_Current.xlsx").Activate
ActiveWorkbook.Close True
Windows("Report.xlsm").Activate


'' and performs a lookup against the DATASHEET tab, matching the Account Number. It currently only
'' shows values if they are found/non-zero.  It also clears old data from the columns
'' This also copies the outputed data and pastes only the values.
'' By doing so, we are saving future memory space, so that it doesn't need to recalc everytime you open
'' the file, only when you run this macro.

Sheets("SHEET1").Select
Range("KA25:KC5000").Select
Selection.Delete

Dim LastRow As Long, i As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 25 To LastRow
    Range("KA1").Offset(i - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SUMIF(DATASHEET!R2C1:R712C1,SHEET1!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275])>0,SUMIF(DATASHEET!R2C1:R712C1,SHEET1!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]),"""")"

    Range("KB1").Offset(i - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET1!RC[-1]="""","""",If(SHEET1!RC[-1]>1.1,""RED"",If(SHEET1!RC[-1]<0.8,""GREEN"",""YELLOW"")))"

    Range("KC1").Offset(i - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET1!RC[-1]="""","""",SUMIF(DATASHEET!R2C1:R712C1,SHEET1!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]))"
Next i

Sheets("SHEET1").Select
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00"
Range("KC25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00%"
Range("KA25").Select


Sheets("SHEET2").Select
Range("KA25:KC5000").Select
Selection.Delete

Dim LastRow1 As Long, i1 As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i1 = 25 To LastRow
    Range("KA1").Offset(i1 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SUMIF(DATASHEET!R2C1:R712C1,SHEET2!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275])>0,SUMIF(DATASHEET!R2C1:R712C1,SHEET2!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]),"""")"

    Range("KB1").Offset(i1 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET2!RC[-1]="""","""",If(SHEET2!RC[-1]>1.1,""RED"",If(SHEET2!RC[-1]<0.8,""GREEN"",""YELLOW"")))"

    Range("KC1").Offset(i1 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET2!RC[-1]="""","""",SUMIF(DATASHEET!R2C1:R712C1,SHEET2!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]))"
Next i1

Sheets("SHEET2").Select
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00"
Range("KC25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00%"
Range("KA25").Select


Sheets("SHEET3").Select
Range("KA25:KC5000").Select
Selection.Delete

Dim LastRow2 As Long, i2 As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i2 = 25 To LastRow
    Range("KA1").Offset(i2 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SUMIF(DATASHEET!R2C1:R712C1,SHEET3!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275])>0,SUMIF(DATASHEET!R2C1:R712C1,SHEET3!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]),"""")"

    Range("KB1").Offset(i2 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET3!RC[-1]="""","""",If(SHEET3!RC[-1]>1.1,""RED"",If(SHEET3!RC[-1]<0.8,""GREEN"",""YELLOW"")))"

    Range("KC1").Offset(i2 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET3!RC[-1]="""","""",SUMIF(DATASHEET!R2C1:R712C1,SHEET3!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]))"
Next i2

Sheets("SHEET3").Select
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00"
Range("KC25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00%"
Range("KA25").Select


Sheets("SHEET4").Select
Range("KA25:KC5000").Select
Selection.Delete

Dim LastRow3 As Long, i3 As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i3 = 25 To LastRow
    Range("KA1").Offset(i3 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SUMIF(DATASHEET!R2C1:R712C1,SHEET4!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275])>0,SUMIF(DATASHEET!R2C1:R712C1,SHEET4!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]),"""")"

    Range("KB1").Offset(i3 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET4!RC[-1]="""","""",If(SHEET4!RC[-1]>1.1,""RED"",If(SHEET4!RC[-1]<0.8,""GREEN"",""YELLOW"")))"

    Range("KC1").Offset(i3 - 1, 0).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(SHEET4!RC[-1]="""","""",SUMIF(DATASHEET!R2C1:R712C1,SHEET4!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]))"
Next i3

Sheets("SHEET4").Select
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00"
Range("KC25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00%"
Range("KA25").Select

Sheets("DATASHEET").Visible = xlSheetHidden

Application.EnableEvents = True 'Turns background code back on.
Application.ScreenUpdating = True 'Turns ScreenUpdating back on.
Application.DisplayAlerts = True 'Turns Alerts back on.

MsgBox "Import Complete"

End Sub

You might benefit from reading [How to avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). • If your code is working in gerenral (no errors) then this would better be asked at: https://codereview.stackexchange.com — Pᴇʜ, May 02 '19 at 14:16
You need to name your objects. You can call sheets directly by name. Also, where does this code live? You want to use ThisWorkBook to reference where the code is running from. — HackSlash, May 06 '19 at 22:08

score 0 · Accepted Answer · answered May 06 '19 at 22:26

You want to avoid repeating yourself. Whenever you have duplicate code you need to break it out in to it's own procedure and then call it using the variable that makes it unique. In your case the only unique part is the sheet you are operating on. So I made this example procedure that you can pass sheet objects to:

Private Sub ProcessSheet(thisSheet As Worksheet)

    thisSheet.Range("KA25:KC5000").Delete

    Dim LastRow As Long, i As Long
    LastRow = thisSheet.Cells(thisSheet.Rows.Count, "A").End(xlUp).Row
    For i = 25 To LastRow
        thisSheet.Range("KA1").Offset(i - 1, 0).FormulaR1C1 = _
                               "=IF(SUMIF(DATASHEET!R2C1:R712C1," & thisSheet.Name & "!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275])>0,SUMIF(DATASHEET!R2C1:R712C1," & thisSheet.Name & "!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]),"""")"

        thisSheet.Range("KB1").Offset(i - 1, 0).FormulaR1C1 = _
                               "=IF(" & thisSheet.Name & "!RC[-1]="""","""",If(" & thisSheet.Name & "!RC[-1]>1.1,""RED"",If(" & thisSheet.Name & "!RC[-1]<0.8,""GREEN"",""YELLOW"")))"

        thisSheet.Range("KC1").Offset(i - 1, 0).FormulaR1C1 = _
                               "=IF(" & thisSheet.Name & "!RC[-1]="""","""",SUMIF(DATASHEET!R2C1:R712C1," & thisSheet.Name & "!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]))"
    Next i

    With thisSheet
        .Range("KA25").UsedRange = Sheets("SHEET1").Range("KA25").UsedRange
        .Range("KA25", Selection.End(xlDown)).NumberFormat = "0.00"
        .Range("KC25", Selection.End(xlDown)).NumberFormat = "0.00%"
    End With
End Sub

Then you can call it from your main import procedure like this:

Sub Import()
    With Application
        .EnableEvents = False             'This stops the background codes on the sheets from activating (smoothens out the process).
        .ScreenUpdating = False           'Stops the screen from switching back and forth between the Input and the Master
        .DisplayAlerts = False
    End With

    If InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE1", vbTextCompare) <> 0 Then
        Sheets("SHEET2").Activate
        Range("A4").Select
    ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE2", vbTextCompare) <> 0 Then
        Sheets("SHEET2").Activate
        Range("A4").Select
    ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE3", vbTextCompare) <> 0 Then
        Sheets("SHEET2").Activate
        Range("A4").Select
    ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "All", vbTextCompare) <> 0 Then
        Sheets("SHEET2").Activate
        Range("A4").Select
    Else
        Sheets("SHEET1").Columns("KA:KC").Hidden = True
        Sheets("SHEET2").Columns("KA:KC").Hidden = True
        Sheets("SHEET3").Columns("KA:KC").Hidden = True
        Sheets("SHEET4").Columns("KA:KC").Hidden = True
        MsgBox "Doesn't exist for these locations"
        Exit Sub
    End If

    Sheets("SHEET1").Columns("KA:KC").Hidden = False
    Sheets("SHEET2").Columns("KA:KC").Hidden = False
    Sheets("SHEET3").Columns("KA:KC").Hidden = False
    Sheets("SHEET4").Columns("KA:KC").Hidden = False

    'This removes the old DATASHEET tab from the model before starting (if it exists)
    Dim SummaryWB As Workbook
    Dim vrtSelectedItem As Variant
    For Each Sheet In ActiveWorkbook.Worksheets
        If Sheet.Name = "DATASHEET" Then
            Sheet.Delete
        End If
    Next Sheet

    ''' The below opens the RRS file from the file path defined
    Dim RRSFile As Workbook
    Set RRSFile = Workbooks.Open(Filename:="\\Template_Current.xlsx")

    '' This will allow the workbook to open before continuing
    DoEvents

    '' This copies the Data from the RRS file and moves it into the CPM model in a new tab, and renames it.
    '' It then closes the Source file.
    Dim dataRange As Range
    dataRange = RRSFile.Sheets("Data").Range("A1").UsedRange

    Dim dataSheet As Worksheet
    Windows("Report.xlsm").Activate
    Set dataSheet = Sheets.Add(After:=Sheets("YAdd"))
    dataSheet.Range("A1") = dataRange
    dataSheet.Name = "DATASHEET"
    RRSFile.Sheets("List View").Range ("D3")
    dataSheet.Range("W1") = RRSFile.Sheets("List View").Range("D3")
    RSSFile.Close True
    Windows("Report.xlsm").Activate


    '' and performs a lookup against the DATASHEET tab, matching the Account Number. It currently only
    '' shows values if they are found/non-zero.  It also clears old data from the columns
    '' This also copies the outputed data and pastes only the values.
    '' By doing so, we are saving future memory space, so that it doesn't need to recalc everytime you open
    '' the file, only when you run this macro.

    ProcessSheet Sheets("SHEET1")
    ProcessSheet Sheets("SHEET2")
    ProcessSheet Sheets("SHEET3")
    ProcessSheet Sheets("SHEET4")

    Sheets("DATASHEET").Visible = xlSheetHidden

    With Application
        .EnableEvents = True              'Turns background code back on.
        .ScreenUpdating = True            'Turns ScreenUpdating back on.
        .DisplayAlerts = True             'Turns Alerts back on.
    End With

    MsgBox "Import Complete"

End Sub

The big benefit you get here is that you can change that code in one place and it affects all 4 of your loops. Instead of trying to maintain 4 identical copies of the same code.

Thank you @HackSlash. That makes total sense to move the loop into its own process. I truly appreciate your answer! — nikedude, May 06 '19 at 23:26

How to optimize multiple loops in VBA code within Excel

1 Answers1