• 1

• 417
• 1
• 4
• 10

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