Excel Forum

Code: Select all

Sub TestVBA()
    OptimizeVBA True
    Dim startTime As Single, endTime As Single
    startTime = Timer
    
    Dim invoice As Range, names As Range, Amount As Range
    Dim lookupInvoice As Range, lookupNames As Range, lookupAmount As Range
    Dim vlookupCol As Object
    
    Set invoice = Worksheets("Sheet2").Range("A2:A199")
    Set names = Worksheets("Sheet2").Range("B2:B199")
    Set Amount = Worksheets("Sheet2").Range("C2:C199")
    Set lookupInvoice = Worksheets("Sheet1").Range("A2:A12")
    Set lookupNames = Worksheets("Sheet1").Range("B2:B12")
    Set lookupAmount = Worksheets("Sheet1").Range("C2:C12")
    'Build Collection
    Set vlookupCol =[color=#FF0000] BuildLookupCollection(invoice[/color], names, Amount)
    
    'Lookup the values
    VLookupValues lookupInvoice, lookupNames, lookupAmount, vlookupCol
    endTime = Timer
    Debug.Print (endTime - startTime) & " seconds have passed [VBA]"
    OptimizeVBA False
    Set vlookupCol = Nothing
End Sub
 
Function BuildLookupCollection(categories As Range, values As Range)
    Dim vlookupCol As Object, i As Long
    Set vlookupCol = CreateObject("Scripting.Dictionary")
    For i = 1 To categories.Rows.Count
        Call vlookupCol.Add(CStr(categories(i)), values(i))
    Next i
    
    Set BuildLookupCollection = vlookupCol
End Function
 
Sub VLookupValues(lookupCategory As Range, lookupValues As Range, vlookupCol As Object)
    Dim i As Long, resArr() As Variant
    ReDim resArr(lookupCategory.Rows.Count, 1)
    For i = 1 To lookupCategory.Rows.Count
        resArr(i - 1, 0) = vlookupCol.Item(CStr(lookupCategory(i)))
    Next i
    lookupValues = resArr
End Sub
 
Sub OptimizeVBA(isOn As Boolean)
    Application.Calculation = IIf(isOn, xlCalculationManual, xlCalculationAutomatic)
    Application.EnableEvents = Not (isOn)
    Application.ScreenUpdating = Not (isOn)
    ActiveSheet.DisplayPageBreaks = Not (isOn)
End Sub

Code: Select all

Function BuildLookupCollection(categories As Range, values As Range, amt As Range)
    Dim vlookupCol As Object, i As Long
    Set vlookupCol = CreateObject("Scripting.Dictionary")
    For i = 1 To categories.Rows.Count
        Call vlookupCol.Add(CStr(categories(i)), values(i))
    Next i
    
    Set BuildLookupCollection = vlookupCol
End Function
 
Sub VLookupValues(lookupCategory As Range, lookupValues As Range, amt As Range, vlookupCol As Object)
    Dim i As Long, resArr() As Variant
    ReDim resArr(lookupCategory.Rows.Count, 1)
    For i = 1 To lookupCategory.Rows.Count
        resArr(i - 1, 0) = vlookupCol.Item(CStr(lookupCategory(i)))
    Next i
    lookupValues = resArr
End Sub