6
\$\begingroup\$

I was given code a while back that was a mess, and have completely rewritten it. However now the code takes .2 seconds per line which for a 500,000 line document is much too long.

Purpose of the Code: This code takes the new information that has been provided by a cleaned data dump and recalculates all columns based on the new information. A large number of VLookups are employed to cross reference the data between the sheets.

Notes:

  • We are investing in either a new program or frame for this data (possibly R), but it needs to be functional in two months and the individuals who are experts in R are tied up in other high priority projects for the next 5 months and IT estimates 7 months before they could put something together. Therefore I was tasked with getting this version to run.
  • The report has to be finished each morning before 10:00am so there is a strong preference to get it under 3 hours of total processing time. Currently it would take approximately 28 hours to run.
  • I have never done optimisation before, I have not used data tables, I do not know python or SQL. I am willing to learn any/all of these things if you are willing to point me in the direction of what aspects I should focus on learning. I am also self taught in VBA and am constantly learning new ways to improve my code and formatting.
  • Everything before it starts looping through "For RC =2 To lrMain" takes about a three minutes total to run all lines. I am not as concerned about it.
  • There are no in cell computations happening anywhere on this workbook.
  • Unless it is absolutely necessary restructuring the data and sheets is not an option, however creating additional sheets or files to hold data is not an issue.
  • I appreciate any and all help on this. I am in way over my head.

Sub Calculate_Click()

Dim wsMain As Worksheet
Dim wsQuantity As Worksheet
Dim wsVelocity As Worksheet
Dim wsParameters As Worksheet
Dim wsData As Worksheet
Dim lrMain As Long 'lr = last row'
Dim lrQuantity As Long
Dim lrVelocity As Long
Dim lrParameters As Long
Dim lrData As Long
Dim conUD As String 'con=concatenate'
Dim conECD As String
Dim calcWeek As Long
Dim RC As Long 'Row Counter'
Dim vl As Variant 'Vlookup, Variant to allow for errors without breaking the code'

'For Optimization Testing Only.'
Dim MainTimer As Double
MainTimer = Timer

Set wsMain = Worksheets("Main Tab")
Set wsQuantity = Worksheets("Quantity Available")
Set wsVelocity = Worksheets("Velocity")
Set wsParameters = Worksheets("Parameters")
Set wsData = Worksheets("Data Input by Account")
lrMain = wsMain.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
lrQuantity = wsQuantity.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
lrVelocity = wsVelocity.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
lrParameters = wsParameters.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
lrData = wsData.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
calcWeek = wsParameters.Range("B3").Value

'******************* Insert a line to freeze screen here.'

For RC = 2 To lrQuantity
    With wsQuantity
        .Cells(RC, 5) = .Cells(RC, 1) & .Cells(RC, 2)
        .Cells(RC, 6) = .Cells(RC, 1) & UCase(.Cells(RC, 2).Value) & .Cells(RC, 3)
    End With
Next RC

wsData.Range(wsData.Cells(2, 1), wsData.Cells(lrData, 4)).Sort _
        key1:=wsData.Range("A2"), order1:=xlAscending, Header:=xlNo

For RC = 2 To lrData
    vl = Application.VLookup(wsData.Cells(RC, 2), wsParameters.Range("Table5"), 2, False)
        If IsError(vl) Then
            wsData.Cells(RC, 3).Value = "Missing"
        Else
            wsData.Cells(RC, 3).Value = vl
        End If
Next RC

For RC = 2 To lrVelocity
    With wsVelocity
        .Cells(RC, 10) = .Cells(RC, 1) & .Cells(RC, 4) & .Cells(RC, 5) & .Cells(RC, 9)
        .Cells(RC, 10).Value = CStr(Trim(.Cells(RC, 10).Value))
        .Cells(RC, 11) = .Cells(RC, 6)
        .Cells(RC, 12) = .Cells(RC, 7)
        .Cells(RC, 13) = .Cells(RC, 8)
        .Cells(RC, 14) = .Cells(RC, 3)
        .Cells(RC, 22) = .Cells(RC, 1) & .Cells(RC, 9)
    End With
Next RC

wsVelocity.Range(wsVelocity.Cells(2, 1), wsVelocity.Cells(lrVelocity, 10)).Sort _
        key1:=wsVelocity.Range("J2"), order1:=xlAscending, Header:=xlNo


For RC = 2 To lrMain


    wsMain.Cells(RC, 21) = wsMain.Cells(RC, 5) & wsMain.Cells(RC, 3)

    If wsMain.Cells(RC, 8) <> 0 Then
        wsMain.Cells(RC, 9) = wsMain.Cells(RC, 6) / wsMain.Cells(RC, 8)
    End If

    conUD = wsMain.Cells(RC, 21) & wsMain.Cells(RC, 4) & calcWeek
    conUD = CStr(Trim(conUD))

    vl = Application.VLookup(conUD, wsVelocity.Range(wsVelocity.Cells(2, 10), wsVelocity.Cells(lrVelocity, 11)), 2, False)
    If IsError(vl) Then
        wsMain.Cells(RC, 10).Value = "Missing"
    Else
        wsMain.Cells(RC, 10).Value = vl
    End If

    vl = Application.VLookup(conUD, wsVelocity.Range(wsVelocity.Cells(2, 10), wsVelocity.Cells(lrVelocity, 14)), 5, False)
    If IsError(vl) Then
        wsMain.Cells(RC, 11).Value = "Missing"
    Else
        wsMain.Cells(RC, 11).Value = vl
    End If

    If wsMain.Cells(RC, 11) <> 0 And wsMain.Cells(RC, 9) > wsMain.Cells(RC, 11) Then
        wsMain.Cells(RC, 12).Value = Round((wsMain.Cells(RC, 6) / wsMain.Cells(RC, 11)) / wsMain.Cells(RC, 10), 0.1)
    Else
        wsMain.Cells(RC, 12).Value = ""
    End If

    If wsMain.Cells(RC, 6) > 0 And wsMain.Cells(RC, 12) <> "" Then
        wsMain.Cells(RC, 13).Value = wsMain.Cells(RC, 12) - wsMain.Cells(RC, 8)
    Else
        wsMain.Cells(RC, 13).Value = ""
    End If

    conECD = wsMain.Cells(RC, 5) & wsMain.Cells(RC, 3) & wsMain.Cells(RC, 4) & calcWeek
    vl = Application.VLookup(conECD, wsVelocity.Range(wsVelocity.Cells(2, 10), wsVelocity.Cells(lrVelocity, 14)), 3, False)
    If wsMain.Cells(RC, 12) > 0 And wsMain.Cells(RC, 12) <> "" And wsMain.Cells(RC, 13) <> "" Then
        If IsError(vl) Then
            wsMain.Cells(RC, 14).Value = "Missing"
        Else
            wsMain.Cells(RC, 14).Value = Int(wsMain.Cells(RC, 13) / vl)
        End If
    End If

    vl = Application.VLookup(conECD, wsVelocity.Range(wsVelocity.Cells(2, 10), wsVelocity.Cells(lrVelocity, 14)), 4, False)
    If IsError(vl) Then
        wsMain.Cells(RC, 15) = "Missing"
    Else
        If wsMain.Cells(RC, 14) > vl And wsMain.Cells(RC, 14) <> "" Then
            wsMain.Cells(RC, 15).Value = vl
        Else
            wsMain.Cells(RC, 15).Value = wsMain.Cells(RC, 14).Value
        End If
    End If

   If wsMain.Cells(RC, 14) = "Missing" Or wsMain.Cells(RC, 14) = "" Or wsMain.Cells(RC, 11) = "Missing" Or wsMain.Cells(RC, 11) = "" Then
        wsMain.Cells(RC, 26).Value = ""
    Else
        wsMain.Cells(RC, 26).Value = Round(wsMain.Cells(RC, 14).Value * wsMain.Cells(RC, 11).Value, 0)
    End If



    vl = Application.Index(wsQuantity.Range(wsQuantity.Cells(2, 4), wsQuantity.Cells(lrQuantity, 4)), _
            Application.Match((wsMain.Cells(RC, 21).Value & "LIBERTY"), wsQuantity.Range(wsQuantity.Cells(2, 6), wsQuantity.Cells(lrQuantity, 6)), False))
    If IsError(vl) Then
        wsMain.Cells(RC, 24).Value = ""
    Else
        wsMain.Cells(RC, 24).Value = vl
    End If

    wsMain.Cells(RC, 18).Value = wsMain.Cells(RC, 24) - Application.SumIf(wsMain.Range(wsMain.Cells(1, 21), wsMain.Cells(RC, 21)), wsMain.Cells(RC, 21).Value, wsMain.Range(wsMain.Cells(1, 26), wsMain.Cells(RC, 26)))

    If wsMain.Cells(RC, 18).Value < 0 Then
        wsMain.Cells(RC, 29).Value = "C"
    Else
        wsMain.Cells(RC, 29).Value = ""
    End If

    vl = Application.VLookup(conECD, wsVelocity.Range(wsVelocity.Cells(2, 10), wsVelocity.Cells(RC, 14)), 4)
    If IsError(vl) Then
        wsMain.Cells(RC, 28) = "Missing"
    Else
        If wsMain.Cells(RC, 26) > vl And wsMain.Cells(RC, 26) <> "" Then
            wsMain.Cells(RC, 28).Value = vl
        Else
            wsMain.Cells(RC, 28).Value = wsMain.Cells(RC, 26).Value
        End If
    End If

    If wsMain.Cells(RC, 29).Value = "C" Then
        wsMain.Cells(RC, 27).Value = 0
    Else
        wsMain.Cells(RC, 27).Value = wsMain.Cells(RC, 28)
    End If

    wsMain.Cells(RC, 31).Value = Application.SumIf(wsMain.Range(wsMain.Cells(2, 1), wsMain.Cells(lrMain, 1)), wsMain.Cells(RC, 1).Value, wsMain.Range(wsMain.Cells(2, 27), wsMain.Cells(lrMain, 27)))

    If wsMain.Cells(RC, 5) = "" Then
        wsMain.Cells(RC, 35) = ""
    Else
        wsMain.Cells(RC, 35).Value = Application.Index(wsVelocity.Range(wsVelocity.Cells(2, 7), wsVelocity.Cells(lrVelocity, 7)), _
            Application.Match(wsMain.Cells(RC, 5), wsVelocity.Range(wsVelocity.Cells(2, 1), wsVelocity.Cells(lrVelocity, 1)), False))
    End If

    If wsMain.Cells(RC, 6).Value = 0 Or wsMain.Cells(RC, 6).Value = "Missing" Or wsMain.Cells(RC, 10).Value = "Missing" Then
        wsMain.Cells(RC, 44).Value = 0
    Else
        wsMain.Cells(RC, 44).Value = Round(((((wsMain.Cells(RC, 6).Value / wsMain.Cells(RC, 11).Value) _
            / wsMain.Cells(RC, 10).Value) - wsMain.Cells(RC, 8).Value) / wsMain.Cells(RC, 35).Value), 0.1)
    End If

    If wsMain.Cells(RC, 11).Value = 0 Or wsMain.Cells(RC, 10).Value = "Missing" Then
        wsMain.Cells(RC, 34).Value = 0
    Else
        If wsMain.Cells(RC, 6).Value = 0 Then
            wsMain.Cells(RC, 34).Value = 0
        Else
            wsMain.Cells(RC, 34).Value = Round(((((wsMain.Cells(RC, 6) / wsMain.Cells(RC, 11)) _
            / wsMain.Cells(RC, 10)) - wsMain.Cells(RC, 8)) / wsMain.Cells(RC, 35)) * wsMain.Cells(RC, 11), 0.1)
        End If
    End If

    If wsMain.Cells(RC, 34) < 0 Then
        wsMain.Cells(RC, 33) = 0
    Else
        wsMain.Cells(RC, 33) = wsMain.Cells(RC, 34)
    End If

    If wsMain.Cells(RC, 1) = "" Then
        wsMain.Cells(RC, 37).Value = ""
    Else
        wsMain.Cells(RC, 37) = 1 + calcWeek
    End If

    If wsMain.Cells(RC, 37) = "" Then
        wsMain.Cells(RC, 38).Value = ""
    Else
        wsMain.Cells(RC, 38) = wsMain.Cells(RC, 5) & wsMain.Cells(RC, 37)
    End If

    wsMain.Cells(RC, 39).Value = Application.Index(wsVelocity.Range(wsVelocity.Cells(2, 3), wsVelocity.Cells(lrVelocity, 3)), _
        Application.Match(wsMain.Cells(RC, 38), wsVelocity.Range(wsVelocity.Cells(2, 22), wsVelocity.Cells(lrVelocity, 22)), False))

    If wsMain.Cells(RC, 11) = 0 Or wsMain.Cells(RC, 10) = "Missing" Then
        wsMain.Cells(RC, 40) = 0
    Else
        wsMain.Cells(RC, 40) = Round(((((wsMain.Cells(RC, 6) / wsMain.Cells(RC, 11)) * wsMain.Cells(RC, 39)) _
            - wsMain.Cells(RC, 6)) - (wsMain.Cells(RC, 8) - wsMain.Cells(RC, 6))) / wsMain.Cells(RC, 35), 0.1)
    End If

    If wsMain.Cells(RC, 40) = "" Then
        wsMain.Cells(RC, 41) = ""
    Else
        If wsMain.Cells(RC, 40) < 0 Then
            wsMain.Cells(RC, 41) = 0
        Else
            wsMain.Cells(RC, 41) = wsMain.Cells(RC, 40)
        End If
    End If

    If wsMain.Cells(RC, 41) = "" Then
        wsMain.Cells(RC, 42) = ""
    Else
        wsMain.Cells(RC, 42) = wsMain.Cells(RC, 41) - wsMain.Cells(RC, 33)
    End If

    If wsMain.Cells(RC, 11) < wsMain.Cells(1, 44) Then
        wsMain.Cells(RC, 45) = 0
    Else
        If wsMain.Cells(RC, 44) < 0 Then
            wsMain.Cells(RC, 45) = ""
        Else
            wsMain.Cells(RC, 45) = wsMain.Cells(RC, 44)
        End If
    End If

    If wsMain.Cells(RC, 11) < wsMain.Cells(1, 44) Then
        wsMain.Cells(RC, 32) = wsMain.Cells(RC, 45)
    Else
        wsMain.Cells(RC, 32) = Application.Max(wsMain.Cells(RC, 33), wsMain.Cells(RC, 41))
    End If

    If wsMain.Cells(RC, 31) < wsParameters.Cells(7, 2) Then
        wsMain.Cells(RC, 47) = 0
    Else
        wsMain.Cells(RC, 47) = wsMain.Cells(RC, 27)
    End If

    wsMain.Cells(RC, 46) = wsMain.Cells(RC, 1) & wsMain.Cells(RC, 22) & wsMain.Cells(RC, 47)

If (RC Mod 100) = 0 Then
Debug.Print "Got to row "; RC; " in "; Timer - MainTimer; " seconds."
End If

Next RC
End Sub

Troubleshooting the answer code: For some reason the "BuildVelocityLookup" is only looping through twice instead of once for each row.

'At the very top of the module, before "Option Explicit"
Dim velocityLookup As Scripting.Dictionary
Const Velocity_Key_Col As Long = 10



Sub BuildVelocityLookup(target As Worksheet, keyCol As Long, lookup As Scripting.Dictionary)
    Set lookup = New Scripting.Dictionary
    With target
        Dim lastRow As Long
        lastRow = .Range(.Cells(2, keyCol), .Cells(.Rows.Count, keyCol)).End(xlUp).Row
        Dim keys As Variant
        keys = .Range(.Cells(2, keyCol), .Cells(lastRow, keyCol)).Value
        Dim i As Long
        For i = LBound(keys) To UBound(keys)
            'Note that the row is offset from the array.
            lookup.Add keys(i, 1), i + 1
        Next
    End With
End Sub

' ******** This Sub is written by Emily Alden. Please reach out to her before editing.

Sub Calculate_Click()

'******************* Insert a line to freeze screen here.

    Dim wsMain As Worksheet
    Dim wsQuantity As Worksheet
    Dim wsVelocity As Worksheet
    Dim wsParameters As Worksheet
    Dim wsData As Worksheet
    Dim lrMain As Long 'lr = last row
    Dim lrQuantity As Long
    Dim lrVelocity As Long
    Dim lrParameters As Long
    Dim lrData As Long
    Dim i As Long 'Row Counter

    'For Optimization Testing Only.
    Dim MainTimer As Double
    MainTimer = Timer

    Set wsMain = Worksheets("Main Tab")
    Set wsQuantity = Worksheets("Quantity Available")
    Set wsVelocity = Worksheets("Velocity")
    Set wsParameters = Worksheets("Parameters")
    Set wsData = Worksheets("Data Input by Account")

    lrMain = wsMain.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
    lrQuantity = wsQuantity.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
    lrVelocity = wsVelocity.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
    lrParameters = wsParameters.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
    lrData = wsData.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row

    Dim calcWeek As Long
    calcWeek = wsParameters.Range("B3").Value

    For i = 2 To 5 'lrQuantity
        With wsQuantity
            .Cells(i, 5) = .Cells(i, 1) & .Cells(i, 2)
            .Cells(i, 6) = .Cells(i, 1) & UCase(.Cells(i, 2).Value) & .Cells(i, 3)
        End With
    Next i

    wsData.Range(wsData.Cells(2, 1), wsData.Cells(lrData, 4)).Sort _
    key1:=wsData.Range("A2"), order1:=xlAscending, Header:=xlNo

    Dim tempLookup As Variant
    For i = 2 To 5 'lrData
        tempLookup = Application.VLookup(wsData.Cells(i, 2), wsParameters.Range("Table5"), 2, False)
        If IsError(tempLookup) Then
            wsData.Cells(i, 3).Value = "Missing"
        Else
            wsData.Cells(i, 3).Value = tempLookup
        End If
    Next i

    For i = 2 To 5 'lrVelocity
        With wsVelocity
            .Cells(i, 10) = .Cells(i, 1) & .Cells(i, 4) & .Cells(i, 5) & .Cells(i, 9)
            .Cells(i, 10).Value = CStr(Trim(.Cells(i, 10).Value))
            .Cells(i, 11) = .Cells(i, 6)
            .Cells(i, 12) = .Cells(i, 7)
            .Cells(i, 13) = .Cells(i, 8)
            .Cells(i, 14) = .Cells(i, 3)
            .Cells(i, 22) = .Cells(i, 1) & .Cells(i, 9)
        End With
    Next i

    wsVelocity.Range(wsVelocity.Cells(2, 1), wsVelocity.Cells(lrVelocity, 10)).Sort _
    key1:=wsVelocity.Range("J2"), order1:=xlAscending, Header:=xlNo

    BuildVelocityLookup wsVelocity, Velocity_Key_Col, velocityLookup

    Dim indexVelocity1 As Range
    Dim indexVelocity2 As Range
    Dim matchVelocity1 As Range
    Dim matchVelocity2 As Range

    With wsVelocity
        Set indexVelocity1 = .Range(.Cells(2, 7), .Cells(lrVelocity, 7))
        Set indexVelocity2 = .Range(.Cells(2, 3), .Cells(lrVelocity, 3))
        Set matchVelocity1 = .Range(.Cells(2, 1), .Cells(lrVelocity, 1))
        Set matchVelocity2 = .Range(.Cells(2, 22), .Cells(lrVelocity, 22))
    End With

    Dim indexQuantity As Range
    Dim matchQuantity As Range
    With wsQuantity
        Set indexQuantity = .Range(.Cells(2, 4), .Cells(lrQuantity, 4))
        Set matchQuantity = .Range(.Cells(2, 6), .Cells(lrQuantity, 6))
    End With

    Dim ShipMin As Long
    ShipMin = wsParameters.Cells(7, 2).Value

    wsMain.Activate
    With wsMain
        .Range(.Cells(2, 9), Cells(lrMain, 47)).ClearContents
    End With

    For i = 2 To lrMain
        With wsMain
            Dim conUD As String 'con=concatenate
            conUD = .Cells(i, 21) & .Cells(i, 4) & calcWeek

            Dim velocityRow As Long
            If velocityLookup.Exists(conUD) Then
                velocityRow = velocityLookup.Item(conUD)
                tempLookup = wsVelocity.Cells(velocityRow, 1)
            End If

            .Cells(i, 21) = .Cells(i, 5) & .Cells(i, 3)

            If .Cells(i, 8) <> 0 Then
                .Cells(i, 9) = .Cells(i, 6) / .Cells(i, 8)
            End If

            If velocityLookup.Exists(conUD) Then
                velocityRow = velocityLookup.Item(conUD)
                tempLookup = wsVelocity.Cells(velocityRow, 12)
            End If
            .Cells(i, 10).Value = tempLookup

            If velocityLookup.Exists(conUD) Then
                velocityRow = velocityLookup.Item(conUD)
                tempLookup = wsVelocity.Cells(velocityRow, 15)
            End If
                .Cells(i, 11).Value = tempLookup

            If .Cells(i, 9) > .Cells(i, 11) Then
                .Cells(i, 12).Value = Round((.Cells(i, 6) / .Cells(i, 11)) / .Cells(i, 10), 0.1)
            End If

            If .Cells(i, 6) > 0 Then
                If .Cells(i, 12) <> "" Then
                    .Cells(i, 13).Value = .Cells(i, 12) - .Cells(i, 8)
                End If
            End If

            Dim conECD As String
            conECD = .Cells(i, 5) & .Cells(i, 3) & .Cells(i, 4) & calcWeek
            If velocityLookup.Exists(conUD) Then
                velocityRow = velocityLookup.Item(conUD)
                tempLookup = wsVelocity.Cells(velocityRow, 3)
            End If

            If .Cells(i, 13) <> "" Then
                If tempLookup <> 0 Then
                    .Cells(i, 14).Value = Int(.Cells(i, 13) / tempLookup)
                End If
            End If

            If velocityLookup.Exists(conUD) Then
                velocityRow = velocityLookup.Item(conUD)
                tempLookup = wsVelocity.Cells(velocityRow, 14)
            End If
            If .Cells(i, 14) > tempLookup Then
                If .Cells(i, 14) <> "" Then
                    .Cells(i, 15).Value = tempLookup
                End If
            Else
                .Cells(i, 15).Value = .Cells(i, 14).Value
            End If

            If .Cells(i, 14) = "" Then
                If .Cells(i, 11) = "" Then
                    .Cells(i, 26) = ""
                Else
                    .Cells(i, 26).Value = Round(.Cells(i, 14).Value * .Cells(i, 11).Value, 0)
                End If
            End If

            tempLookup = Application.Index(indexQuantity, Application.Match((.Cells(i, 21).Value & "LIBERTY") _
                , matchQuantity, False))
            .Cells(i, 24).Value = tempLookup

            .Cells(i, 18).Value = .Cells(i, 24) - Application.SumIf(.Range(.Cells(1, 21), .Cells(i, 21)), _
                .Cells(i, 21).Value, .Range(.Cells(1, 26), .Cells(i, 26)))

            If velocityLookup.Exists(conUD) Then
                velocityRow = velocityLookup.Item(conUD)
                tempLookup = wsVelocity.Cells(velocityRow, 14)
            End If
            If .Cells(i, 26) > tempLookup Then
                .Cells(i, 28).Value = tempLookup
            Else
                .Cells(i, 28).Value = .Cells(i, 26).Value
            End If

            If .Cells(i, 18).Value < 0 Then
                .Cells(i, 29).Value = "C"
                .Cells(i, 27).Value = ""
            Else
                .Cells(i, 27) = .Cells(i, 28)
            End If

        .Cells(i, 31).Value = Application.SumIf(.Range(.Cells(2, 1), .Cells(lrMain, 1)), _
            .Cells(i, 1).Value, .Range(.Cells(2, 27), .Cells(lrMain, 27)))

            If .Cells(i, 5) = "" Then
                .Cells(i, 35) = ""
            Else
                .Cells(i, 35).Value = Application.Index(indexVelocity1, _
                Application.Match(.Cells(i, 5), matchVelocity1, False))
            End If

            If .Cells(i, 6).Value = 0 Then
                .Cells(i, 44).Value = 0
            Else
                .Cells(i, 44).Value = Round(((((.Cells(i, 6).Value / .Cells(i, 11).Value) _
                    / .Cells(i, 10).Value) - .Cells(i, 8).Value) / .Cells(i, 35).Value), 0.1)
            End If

            If .Cells(i, 6).Value = 0 Then
                .Cells(i, 34).Value = 0
                .Cells(i, 33) = 0
            Else
                .Cells(i, 34).Value = Round(((((.Cells(i, 6) / .Cells(i, 11)) / _
                .Cells(i, 10)) - .Cells(i, 8)) / .Cells(i, 35)) * .Cells(i, 11), 0.1)
                If .Cells(i, 34) > 0 Then
                    .Cells(i, 33) = .Cells(i, 34)
                Else
                    .Cells(i, 33) = 0
                End If
            End If

            .Cells(i, 37) = 1 + calcWeek
            .Cells(i, 38) = .Cells(i, 5) & .Cells(i, 37)
            .Cells(i, 39).Value = Application.Index(indexVelocity2, _
                Application.Match(.Cells(i, 38), matchVelocity2, False))
            .Cells(i, 40) = Round(((((.Cells(i, 6) / .Cells(i, 11)) * .Cells(i, 39)) _
                - .Cells(i, 6)) - (.Cells(i, 8) - .Cells(i, 6))) / .Cells(i, 35), 0.1)

            If .Cells(i, 40) < 0 Then
                .Cells(i, 41) = 0
            Else
                .Cells(i, 41) = .Cells(i, 40)
            End If

            .Cells(i, 42) = .Cells(i, 41) - .Cells(i, 33)

            If .Cells(i, 11) < .Cells(1, 44) Then
                .Cells(i, 45) = 0
                .Cells(i, 32) = .Cells(i, 45)
            Else
                .Cells(i, 32) = Application.Max(.Cells(i, 33), .Cells(i, 41))
                If .Cells(i, 44) < 0 Then
                    .Cells(i, 45) = ""
                Else
                    .Cells(i, 45) = .Cells(i, 44)
                End If
            End If

            If .Cells(i, 31) < ShipMin Then
                .Cells(i, 47) = 0
            Else
                .Cells(i, 47) = .Cells(i, 27)
            End If

            .Cells(i, 46) = .Cells(i, 1) & .Cells(i, 22) & .Cells(i, 47)


        End With

        If (i Mod 100) = 0 Then
            Debug.Print "Got to row "; i; " in "; Timer - MainTimer; " seconds."
        End If
    Next i

End Sub
\$\endgroup\$
12
  • 2
    \$\begingroup\$ 28 hours Ouch! At first, glance, there is far too much testing on the sheets, you should load the sheets in arrays and work as much as possible with the arrays, you'll gain a LOT of time just with that. Furthermore, you don't seem to have any kind of perf improvements tuning of the application. I was about to post one of my wrappers to get some opinions on it, I'll come back in a bit to give the link so that you can see what I mean! ;) Try to rewrite this with arrays meanwhile, I can promise you it'll be worth it! ;) \$\endgroup\$ – R3uK Mar 17 '17 at 14:47
  • 1
    \$\begingroup\$ Unless you're doing some really extensive processing, something like this should really only be running on the order of minutes (if not seconds). \$\endgroup\$ – Comintern Mar 17 '17 at 14:50
  • 1
    \$\begingroup\$ That just means there's going to be a lot of review material. ;-) \$\endgroup\$ – Comintern Mar 17 '17 at 14:56
  • 1
    \$\begingroup\$ @EmilyAlden : Yup, it stands for performances : See codereview.stackexchange.com/questions/158048/… \$\endgroup\$ – R3uK Mar 17 '17 at 15:01
  • 2
    \$\begingroup\$ When you say "recalculates all columns based on the new information", are you referring to only the cell writes that you're performing in the code, or are there formulas on the worksheets that would effect the results of your lookups? \$\endgroup\$ – Comintern Mar 17 '17 at 15:02
4
\$\begingroup\$

Housekeeping Type Things


Just a couple of housekeeping type things first. I'd indent everything between Sub Calculate_Click() and End Sub one more level, and indent the timing code at the bottom to the correct level. It might seem like a small thing, but it really improves the readability of the procedure.


The identifier RC is a bit confusing at first glance, as is vl. I realize that they're just loop counters\temp value holders, but the comments that explain that are a long trip with the mouse wheel up to the top of the procedure. If you want to use a short throw-away loop counter, I'd suggest using i instead - it's pretty generally recognized as shorthand for "index". There's also nothing wrong with something explicit as to what it is like rowCounter or currentRow.


That leads to another readability issue. In a procedure this long, declaring everything in a Dim block at the top of the procedure makes it more difficult to keep track of what everything is, especially when you're using identifiers like conUD. It's usually more readable to declare a variable immediately before you use it the first time.


There are magic numbers everywhere. This makes it both confusing and non-obvious what cell and range indexes are referring to. I'd replace them with descriptive constants that make it obvious what is happening - this also makes your code much easier to maintain if the layout changes:

'Module level declarations
Const FOO_COLUMN As Long = 7
'etc...

Then your code looks more like this:

wsMain.Cells(i, FOO_COLUMN) = wsMain.Cells(i, BAR_COLUMN) & wsMain.Cells(i, BAZ_COLUMN)

I'd get into the habit of using the built in vbNullString constant. It's easier to read at a glance and doesn't require a memory allocation for an empty string.


Performance Type Things


Cache objects and values that you repeatedly use - Consider this code:

vl = Application.VLookup(conECD, wsVelocity.Range(wsVelocity.Cells(2, 10), wsVelocity.Cells(lrVelocity, 14)), 3, False)
If wsMain.Cells(RC, 12) > 0 And wsMain.Cells(RC, 12) <> "" And wsMain.Cells(RC, 13) <> "" Then
    If IsError(vl) Then
        wsMain.Cells(RC, 14).Value = "Missing"
    Else
        wsMain.Cells(RC, 14).Value = Int(wsMain.Cells(RC, 13) / vl)
    End If
End If

vl = Application.VLookup(conECD, wsVelocity.Range(wsVelocity.Cells(2, 10), wsVelocity.Cells(lrVelocity, 14)), 4, False)

You're resolving this Range twice:

wsVelocity.Range(wsVelocity.Cells(2, 10), wsVelocity.Cells(lrVelocity, 14))

Both calls are going to return the exact same result, and they involve 3 function calls on wsVelocity sheet. In general, you should be looking for function calls that are always the same and pull them into a local reference - same thing with calculations that you know will always have the same result. For example:

Dim lookupRange As Range
Set lookupRange = wsVelocity.Range(wsVelocity.Cells(2, 10), wsVelocity.Cells(lrVelocity, 14))
vl = Application.VLookup(conECD, lookupRange, 3, False)
'...
vl = Application.VLookup(conECD, lookupRange, 4, False)

With Blocks - Use them. They aren't just a convenient way to avoid typing the variable name repeatedly - they hold a reference. This means that the VBA runtime doesn't have to resolve them repeatedly. That makes a big difference. Wrap the largest section that you can (I'd probably do the whole loop) and wrap it with the object you use the most:

With wsMain
    For RC = 2 To lrMain
        .Cells(RC, 21) = .Cells(RC, 5) & .Cells(RC, 3)

        If .Cells(RC, 8) <> 0 Then
            .Cells(RC, 9) = .Cells(RC, 6) / .Cells(RC, 8)
        End If

        conUD = .Cells(RC, 21) & .Cells(RC, 4) & calcWeek

        '...

    Next
End With

Short-circuit - VBA doesn't do this natively. When you have multiple conditions in an If statement, VBA will evaluate all of them even if the first False one makes the expression False. For example this code (line breaks for clarity)...

If wsMain.Cells(RC, 12) > 0 And _
   wsMain.Cells(RC, 12) <> "" And _
   wsMain.Cells(RC, 13) <> "" Then

...makes 3 cell reads (two are the same), but if wsMain.Cells(RC, 12) > 0 is False, it doesn't just stop there. You can either nest the statements...

Dim testValue As Variant
testValue = wsMain.Cells(RC, 12)
If testValue > 0 Then
   If testValue <> vbNullString Then
        If wsMain.Cells(RC, 13) <> vbNullString Then

...or if you have a lot of them, use a Select Case structure:

Dim testValue As Variant
testValue = wsMain.Cells(RC, 12)
Select Case False
    Case testValue <= 0
    Case testValue = vbNullString
    Case wsMain.Cells(RC, 13) = vbNullString
    Case Else
        'Your "True" case
End Select

VLookup - Repeated calls to VLookup are expensive, because Excel can't make the assumption that the lookup table will be the same between each call. What that means is that it can't cache anything easily. If (based on your comment) you aren't making changes to the worksheet that the lookups are being performed on or making changes that result in formulas recalculating on the lookup range, it is almost always faster to create your own lookup cache. In this case, after a cursory scan it looks like you're always using the same key column for the lookup. So... just create a set up lookup tables with Dictionary objects with the Value set to the row number (note that this assumes you have unique keys):

'Module level
Dim velocityLookup As Scripting.Dictionary
Const VELOCITY_KEY_COL As Long = 10

Private Sub BuildVelocityLookup(target As Worksheet, keyCol As Long, _
                                lookup As Scripting.Dictionary)
    Set lookup = New Scripting.Dictionary
    With target
        Dim lastRow As Long
        lastRow = .Range(.Cells(2, keyCol), .Cells(.Rows.Count, keyCol)).End(xlUp).Row
        Dim keys As Variant
        keys = .Range(.Cells(2, keyCol), .Cells(lastRow, keyCol)).Value
        Dim i As Long
        For i = LBound(keys) To UBound(keys)
            'Note that the row is offset from the array.
            lookup.Add keys(i, 1), i + 1
        Next
    End With
End Sub

Call that for each of your lookups and use the Dictionary in place of the VLookup:

Sub Calculate_Click()
    BuildVelocityLookup Worksheets("Velocity"), VELOCITY_KEY_COL, velocityLookup
    '...
    Dim velocityRow As Long
    If velocityLookup.Exists(conUD) Then
        velocityRow = velocityLookup.Item(conUD)
        Dim valueYouWant As Variant
        valueYouWant = wsVelocity.Cells(velocityRow, COLUMN_YOU_NEED)
    End If

Use a Value array - This is probably going to be the biggest performance gain if you're able to hold the entire working Range on wsMain in memory at once. If not, you could probably "page" it by processing in chunks of 10000 rows or something like that. The implementation details are probably out of scope for my review (although another reviewer might cover it), but take a look at the BuildVelocityLookup procedure above - it pulls the column into an array and works with that. I'd probably start by tackling to lower hanging fruit above, then switch to array processing if you're still not in the performance neighbourhood you need to be in.

Good luck!

\$\endgroup\$
1
  • \$\begingroup\$ Comments are not for extended discussion; this conversation has been moved to chat. \$\endgroup\$ – Mathieu Guindon Mar 21 '17 at 14:28

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.