4
\$\begingroup\$

Previous Question (Initial Level Optimization) : Excel 'big' data processing with vlookups

Code Purpose: Recalculate 25 columns of 500,000 rows each based on new information (provided by a different macro). Before the previous thread it took 28 hours to run, now it takes 8, my goal is under 3.

Notes

  • We plan on transferring this process into a program designed to hold this much data, but IT and other specialists are tied up in higher priority projects for the next 7 months. I need to get this running by the end of next month when this type of product goes out again.

  • The users have 32 bit Excel and all the restrictions that come with that. I have 64 bit. Currently it takes about a half a Gig to run.

  • The report has to be run each morning before 10:00 am which is why my goal is 3 hours. The current run time, 8 hours, is feasible if IT can have it run automatically in the morning, but I have no knowledge of how to implement that kind of process.

  • I have been using VBA for less than a year and I have no experience with SQL, or arrays. I know those items might help cut time, but I need some guidance on how to implement them and which direction I should go. I've read a few articles about each so I understand the very basics of how they work and if you can tell me particular functions I should look at and their associated restrictions I would greatly appreciate it.

  • The main loop is everything from "For i=2 to lrMain" to the end. The stuff before that runs in about 3 minutes and is not an optimisation concern for me.
  • There are no incell computations anywhere in this workbook, so disabling calculations does not result in a time savings.
  • Restructuring the raw data is not reasonable at this time, however writing to a new sheet or file is not a problem.
  • I greatly appreciate any/all help.

At the top of the module: 

Dim velocityLookup As Scripting.Dictionary
Const Velocity_Key_Col As Long = 10
Option Explicit

BuildVelocityLookup Sub built by Comintern

Sub BuildVelocityLookup(target As Worksheet, keyCol As Long, lookup As Scripting.Dictionary)
    Set lookup = New Scripting.Dictionary
    With target
        Dim lastRow As Long
        lastRow = .Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
        Dim keys As Variant
        keys = .Range(.Cells(2, keyCol), .Cells(lastRow, keyCol)).Value
        Dim j As Long
        For j = LBound(keys) To UBound(keys)
            'Note that the row is offset from the array.
            keys(j, 1) = UCase(keys(j, 1))
            lookup.Add keys(j, 1), j + 1
        Next
    End With
End Sub

Calculate_Click Written by Emily Alden with improvements from Comintern

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, 20)).ClearContents
        .Range(.Cells(2, 22), .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

            .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

            Dim velocityRow As Long
            If velocityLookup.Exists(conUD) Then
                velocityRow = velocityLookup.Item(conUD)
                tempLookup = wsVelocity.Cells(velocityRow, 11)
            End If
            .Cells(i, 10).Value = tempLookup

            tempLookup = wsVelocity.Cells(velocityRow, 14)
            .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(conECD) Then
            velocityRow = velocityLookup.Item(conECD)
            tempLookup = wsVelocity.Cells(velocityRow, 12)
            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(conECD) Then
                velocityRow = velocityLookup.Item(conECD)
                tempLookup = wsVelocity.Cells(velocityRow, 13)
            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, 13)
            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\$
4
  • 1
    \$\begingroup\$ To address your comment about being unfamiliar with arrays, I would recommend experimenting with one in the editor to see how they behave. The easiest way to do this is to declare a variant array, then either ReDim and loop over it, or assign a ListObject.Range.Value (or UsedRange.Value) to it. Unfortunately I dont have any good tutorials on hand, but if you play around with one it should make more sense. In fact, you can think of a 2d array in much the same way as you can think of a spreadsheet. Using an array will be a huge performance increase. \$\endgroup\$
    – Brandon Barney
    Commented Mar 22, 2017 at 18:07
  • 1
    \$\begingroup\$ Also, for having IT run it, look into an OnTime event. All you would need to do is have someone have the workbook open and click a button that triggers the ontime event. You can set the time for the macro to run and it will wait until that time to call the routine. \$\endgroup\$
    – Brandon Barney
    Commented Mar 22, 2017 at 18:08
  • \$\begingroup\$ @BrandonBarney I've played a little with with arrays, followed along with some tutorials, but they often just scratch the surface of what the arrays are capable of and what their restrictions are. I'll look into the OnTime event. The main issue is that it needs to have new data from the previous evening, but I'll check on what time exactly the new data is available. \$\endgroup\$
    – Emily Alden
    Commented Mar 22, 2017 at 18:18
  • 2
    \$\begingroup\$ for now just think of arrays as tables and worry about getting into their more advanced functions later. As in the answers below, we both treat the array as a table in the same way you manipulate cell references. Once you get comfortable with this functionality you can start using their more advanced functions. For now though, moving away from in-cell manipulation will save you a bunch of processing time. \$\endgroup\$
    – Brandon Barney
    Commented Mar 22, 2017 at 19:21

3 Answers 3

Reset to default
4
\$\begingroup\$

I tried adapting you code to use an array for this (someone probably beat me to the punch). I commented old code so you could see the logic of what is happening:

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)

        'Removed .Value to keep things consistent
        .Cells(i, 6) = .Cells(i, 1) & UCase(.Cells(i, 2)) & .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
        ' Combined reformatting into one line
        .Cells(i, 10) = CStr(Trim(.Cells(i, 1) & .Cells(i, 4) & .Cells(i, 5) & .Cells(i, 9)))
        .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 ' Why? No need to activate here.
With wsMain
    .Range(.Cells(2, 9), .Cells(lrMain, 20)).ClearContents
    .Range(.Cells(2, 22), .Cells(lrMain, 47)).ClearContents
End With

Dim arrHolder As Variant

' Check the indices on this. I did my best to assume them using the code.
arrHolder = .Range(wsMain.Cells(2, 1), wsMain.Cells(lrMain, 47))

'For i = 2 To lrMain
' This likely will break cell calculations, but works with the array just fine.
For i = LBound(arrHolder) To lrMain

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

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

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

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

        '.Cells(i, 10).Value = tempLookup
        arrHolder(i, 10) = tempLookup

        tempLookup = wsVelocity.Cells(velocityRow, 14)

        '.Cells(i, 11).Value = tempLookup
        arrHolder(i, 11) = 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 arrHolder(i, 9) > arrHolder(i, 11) Then
            arrHolder(i, 12) = Round((arrHolder(i, 6) / arrHolder(i, 11)) / arrHolder(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
        If arrHolder(i, 6) > 0 Then
            If arrHolder(i, 12) <> vbNullString Then
                arrHolder(i, 13) = arrHolder(i, 12) - arrHolder(i, 8)
            End If
        End If

        Dim conECD As String

        'conECD = .Cells(i, 5) & .Cells(i, 3) & .Cells(i, 4) & calcWeek
        conECD = arrHolder(i, 5) & arrHolder(i, 3) & arrHolder(i, 4) & calcWeek

        ' It looks like you use this block a few times with different variables. Consider extracting to a function
        If velocityLookup.Exists(conECD) Then
            velocityRow = velocityLookup.Item(conECD)
            tempLookup = wsVelocity.Cells(velocityRow, 12)
        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 arrHolder(i, 13) <> vbNullString Then
            If tempLookup <> 0 Then
                arrHolder(i, 14) = Int(arrHolder(i, 13) / tempLookup)
            End If
        End If


        If velocityLookup.Exists(conECD) Then
            velocityRow = velocityLookup.Item(conECD)
            tempLookup = wsVelocity.Cells(velocityRow, 13)
        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 arrHolder(i, 14) > tempLookup Then
            If arrHolder(i, 14) <> vbNullString Then
                arrHolder(i, 15) = tempLookup
            End If
        Else
            arrHolder(i, 15) = arrHolder(i, 14)
        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
        If arrHolder(i, 14) = vbNullString Then
            If arrHolder(i, 11) = vbNullString Then
                arrHolder(i, 26) = vbNullString
            Else
                arrHolder(i, 26) = Round(arrHolder(i, 14) * arrHolder(i, 11), 0)
            End If
        End If


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

        '.Cells(i, 24).Value = tempLookup
        arrHolder(i, 24) = tempLookup

        ' I havent used application SumIf on an array before, so I instead edited this so it should use the correct index value.
        ' This will likely not work as I want it to, so it may just need to go into a separate loop or something.
        ' .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)))
        arrHolder(i, 18) = .Cells(i + 1, 24) - Application.SumIf(.Range(.Cells(1, 21), .Cells(i + 1, 21)), _
            .Cells(i + 1, 21).Value, .Range(.Cells(1, 26), .Cells(i + 1, 26)))

        If velocityLookup.Exists(conUD) Then
            velocityRow = velocityLookup.Item(conUD)
            tempLookup = wsVelocity.Cells(velocityRow, 13)
        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 arrHolder(i, 26) > tempLookup Then
            arrHolder(i, 28) = tempLookup
        Else
            arrHolder(i, 28) = arrHolder(i, 26)
        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
        If arrHolder(i, 18) < 0 Then
            arrHolder(i, 29) = "C"
            arrHolder(i, 27) = vbNullString
        Else
            arrHolder(i, 27) = arrHolder(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)))
        ' Another SumIf. Same as before, we will have to figure this out separately.
        arrHolder(i, 31) = Application.SumIf(.Range(.Cells(2, 1), .Cells(lrMain, 1)), _
            .Cells(i + 1, 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
        ' Thinking about it now, I am not sure about Application Index/Match on an array either.
        If arrHolder(i, 5) = vbNullString Then
            arrHolder(i, 35) = vbNullString
        Else
            arrHolder(i, 35) = Application.Index(indexVelocity1, _
            Application.Match(arrHolder(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 arrHolder(i, 6) = 0 Then
            arrHolder(i, 44) = 0
        Else
            arrHolder(i, 44) = Round(((((arrHolder(i, 6) / arrHolder(i, 11)) _
                / arrHolder(i, 10)) - arrHolder(i, 8)) / arrHolder(i, 35)), 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
        If arrHolder(i, 6) = 0 Then
            arrHolder(i, 34) = 0
            arrHolder(i, 33) = 0
        Else
            arrHolder(i, 34) = Round(((((arrHolder(i, 6) / arrHolder(i, 11)) / _
            arrHolder(i, 10)) - arrHolder(i, 8)) / arrHolder(i, 35)) * arrHolder(i, 11), 0.1)
            If arrHolder(i, 34) > 0 Then
                arrHolder(i, 33) = arrHolder(i, 34)
            Else
                arrHolder(i, 33) = 0
            End If
        End If


        '.Cells(i, 37) = 1 + calcWeek
        arrHolder(i, 37) = 1 + calcWeek

        '.Cells(i, 38) = .Cells(i, 5) & .Cells(i, 37)
        arrHolder(i, 38) = arrHolder(i, 5) & arrHolder(i, 37)

        '.Cells(i, 39).Value = Application.Index(indexVelocity2, _
        '    Application.Match(.Cells(i, 38), matchVelocity2, False))
        arrHolder(i, 39) = Application.Index(indexVelocity2, _
            Application.Match(arrHolder(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)
        arrHolder(i, 40) = Round(((((arrHolder(i, 6) / arrHolder(i, 11)) * arrHolder(i, 39)) _
            - arrHolder(i, 6)) - (arrHolder(i, 8) - arrHolder(i, 6))) / arrHolder(i, 35), 0.1)


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

        '.Cells(i, 42) = .Cells(i, 41) - .Cells(i, 33)
        arrHolder(i, 42) = arrHolder(i, 41) - arrHolder(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
        ' Not 100% sure if applicaiton.max will work here.
        If arrHolder(i, 11) < arrHolder(1, 44) Then
            arrHolder(i, 45) = 0
            arrHolder(i, 32) = arrHolder(i, 45)
        Else
            arrHolder(i, 32) = Application.Max(arrHolder(i, 33), arrHolder(i, 41))
            If arrHolder(i, 44) < 0 Then
                arrHolder(i, 45) = vbNullString
            Else
                arrHolder(i, 45) = arrHolder(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
        If arrHolder(i, 31) < ShipMin Then
            arrHolder(i, 47) = 0
        Else
            arrHolder(i, 47) = arrHolder(i, 27)
        End If

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

    End With

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

wsMain.Range(wsMain.Cells(2, 1), wsMain.Cells(lrMain, 47).Value = arrHolder

Erase arrHolder

End Sub
\$\endgroup\$
4
  • \$\begingroup\$ On the SumIf lines why did you use I+1 instead of I. I've followed everything up until then. \$\endgroup\$
    – Emily Alden
    Commented Mar 22, 2017 at 19:44
  • 1
    \$\begingroup\$ Because your data starts at row 2, but the array is likely going to load in as a 1 base array (meaning it's first row is 1). So 'i' will be '1', but your cell actually needs '2' thus I use a calculation to add an offset of '1' to 'i'. ideally, I would actually calculate the difference between a cell starting point and the LBound of the array, but I dont think I have ever had an issue with assuming the LBound was 1 when assigning a range to an array directly. Also, the offset is only when referencing cells and not arrays. You dont need to offset from array values. \$\endgroup\$
    – Brandon Barney
    Commented Mar 22, 2017 at 19:46
  • \$\begingroup\$ That makes sense. Thank you so much for catching that offset! \$\endgroup\$
    – Emily Alden
    Commented Mar 22, 2017 at 19:49
  • \$\begingroup\$ No problem at all :). Its part of using arrays. You have to be mindful of the index position you are using. \$\endgroup\$
    – Brandon Barney
    Commented Mar 22, 2017 at 19:50
3
\$\begingroup\$

Clearly non-working code, to be used as a guide.

Basically when working with arrays, you copy the data from your Worksheet.Range to a memory-based array in your VBA. Make all changes and calculations to the data within that memory array. Then transfer the finished array data back to the worksheet.

Here is a VERY quick and VERY dirty conversion of your main loop to use an array. Obviously, I can't test the code against any data. The important parts of the array are at the top:

Dim lastRow As Long
Dim lastCol As Long
lastRow = 500000                             'make this a calculation
lastCol = 15                                 'make this a calculation or fixed

'--- capture the data to a memory array
Dim mainData As Variant
Dim mainDataArea As Range
Set mainDataArea = wsMain.Range("A1").Resize(lastRow, lastCol)
mainData = mainDataArea

(You know better how to determine the lastRow and lastCol)

Then after you run your loop, you put it back:

'--- copy the finished array back to the worksheet
mainDataArea = mainData

I did a quick global search and replace to at least get a start on your main loop for you to check out as a guide for what kinds of things you'd have to change.

Const FIRSTNAME = 1   'column constants will make it far easier to debug
Const LASTNAME = 2
Const ADDRESS = 3
Const CITY = 4
Const STATE = 21
' . . .

Dim lastRow As Long
Dim lastCol As Long
lastRow = 500000                             'make this a calculation
lastCol = 15                                 'make this a calculation or fixed

'--- capture the data to a memory array
Dim mainData As Variant
Dim mainDataArea As Range
Set mainDataArea = wsMain.Range("A1").Resize(lastRow, lastCol)
mainData = mainDataArea

For i = 2 To lrMain
    Dim conUD As String                      'con=concatenate
    conUD = mainData(i, 21) & mainData(i, 4) & calcWeek
    '---should be mainData(i, STATE) & mainData(i, CITY) & calcWeek

    mainData(i, 21) = mainData(i, 5) & mainData(i, 3)

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

    Dim velocityRow As Long
    If velocityLookup.Exists(conUD) Then
        velocityRow = velocityLookup.Item(conUD)
        tempLookup = wsVelocitymainData(velocityRow, 11)
    End If
    mainData(i, 10) = tempLookup

    tempLookup = wsVelocitymainData(velocityRow, 14)
    mainData(i, 11) = tempLookup

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

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

    Dim conECD As String
    conECD = mainData(i, 5) & mainData(i, 3) & mainData(i, 4) & calcWeek
    If velocityLookup.Exists(conECD) Then
        velocityRow = velocityLookup.Item(conECD)
        tempLookup = wsVelocitymainData(velocityRow, 12)
    End If

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

    If velocityLookup.Exists(conECD) Then
        velocityRow = velocityLookup.Item(conECD)
        tempLookup = wsVelocitymainData(velocityRow, 13)
    End If
    If mainData(i, 14) > tempLookup Then
        If mainData(i, 14) <> "" Then
            mainData(i, 15) = tempLookup
        End If
    Else
        mainData(i, 15) = mainData(i, 14)
    End If

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

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

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

    If velocityLookup.Exists(conUD) Then
        velocityRow = velocityLookup.Item(conUD)
        tempLookup = wsVelocitymainData(velocityRow, 13)
    End If
    If mainData(i, 26) > tempLookup Then
        mainData(i, 28) = tempLookup
    Else
        mainData(i, 28) = mainData(i, 26)
    End If

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

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

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

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

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

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

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

    mainData(i, 42) = mainData(i, 41) - mainData(i, 33)

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

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

    mainData(i, 46) = mainData(i, 1) & mainData(i, 22) & mainData(i, 47)

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

'--- copy the finished array back to the worksheet
mainDataArea = mainData
\$\endgroup\$
2
  • \$\begingroup\$ This make sense overall. A couple of quick questions: Will the "Application.SumIf" work on an array? Also Index/Match and Max? If not is there a good workaround for these? \$\endgroup\$
    – Emily Alden
    Commented Mar 22, 2017 at 18:51
  • \$\begingroup\$ The SUMIF, INDEX, and MATCH don't work on memory arrays. But you can either re-write your code to not use them, or substitute your own function to replace them. An example of an array-based SUMIF is here. \$\endgroup\$
    – PeterT
    Commented Mar 22, 2017 at 18:54
2
\$\begingroup\$

The slowest parts are usually the multiple calls between VBA and Excel. The main approach to that is to get all contiguous data at once into array, and put it back all at once when done. But! Excel calculations can be done in parallel on multiple threads, and VBA is limited to one thread. Meaning that for a big range, using Excel formulas can be faster than VBA loops over arrays.

For example:

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

can be shortened to:

wsQuantity.Range("E2:E5") = wsQuantity.Evaluate("index(A2:A5 & B2:B5,)")
wsQuantity.Range("F2:F5") = wsQuantity.[index(A2:A5 & Upper(B2:B5) & C2:C5,)]   ' [] is short for Evaluate("")

or:

With wsQuantity.Range("E2:F5")
    .Formula = Array("= A2 & B2", "= A2 & Upper(B2) & C2")  ' relative references (no $) are auto adjusted
    .Value2 = .Value2                                       ' optional to convert the formulas to values
End With

As a side note, I couldn't comprehend more than a page of what the code is doing, but in most cases VBA is not the best approach for aggregating data. There are other alternatives in Excel that are a bit easier than SQL queries like Power Query, Microsoft Query, and in some cases even PivotTable that can get the process down to minutes. I would highly recommend looking into Power Query if your Excel version supports it, as you can use most of it even after moving the process to a database system.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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