Vlookup faster using VBA Dictionary

[Matrixx2525]

Hello,

I'm trying to learn the Dictionary to speed up my Vlookup but it won't work.

My case is very simple: I have Sheet 1 with names+ages and need to add the profession, found in Sheet 2:

Sheet1
=====
Name|Age|Profession
John|25|
Marc|31|
Susan|54|
Karin|21|

Sheet2
=====
Name|profession
Karin|doctor
John|teacher
Karin|unemployed
Marc|shoe salesman

Normally, I would use the simple Vlookup as a formula or in VBA, but I use 100.000+ records, so this solution is slow...

Can anybody give me some code how to add the profession from Sheet2 into Sheet1-row C using the Scripting Dictionary?

Thanks so much in advance, this would really help me.

best regards,

Jeroen

 

[wideboydixon]

Public Sub FastLookup()

Dim nameProfession As New Scripting.Dictionary
Dim lastRow As Long
Dim thisRow As Long

With Sheets("Sheet2")
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For thisRow = 2 To lastRow
        nameProfession.Add .Cells(thisRow, 1).Value, .Cells(thisRow, 2).Value
    Next thisRow
End With

With Sheets("Sheet1")
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For thisRow = 2 To lastRow
        If nameProfession.Exists(.Cells(thisRow, 1).Value) Then
            .Cells(thisRow, 3).Value = nameProfession.Item(.Cells(thisRow, 1).Value)
        Else
            .Cells(thisRow, 3).Value = "#Not Found#"
        End If
    Next thisRow
End With

End Sub

WBD

 

[MickG]

Try this:-
NB:- Your sheet 2 has a Duplicate Name , I assume this is a Typo !!!

Sub MG06Feb28()

Dim Rng As Range, Dn As Range, n As Long, Dic As Object, ray As Variant

With Sheets("Sheet2")

 ray = .Range("A1").CurrentRegion.Resize(, 2)

End With

Set Dic = CreateObject("scripting.dictionary")

Dic.CompareMode = vbTextCompare

For n = 2 To UBound(ray, 1)

    Dic(ray(n, 1)) = ray(n, 2)

Next

With Sheets("Sheet1")

Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))

For Each Dn In Rng

    If Dic.exists(Dn.Value) Then Dn.Offset(, 2) = Dic(Dn.Value)

Next Dn

End With

End Sub

Regards Mick

 

[Matrixx2525]

Thanks all, superfast replies! yes, the duplicate name was a type mismatch

 

[Mark Moscosa]

Hi Mick, I am new to Excel VBA. I was looking for an alternative to standard vlookup and this code works great. I tried to change it a little bit, so that it can also bring a third column value, which is the state.

I couldn't figure out what was necessary, only the current region line to CurrentRegion.Resize(,3)

Thanks for your help,

Sheet1
=====
Name|Age|Profession|State
John|25|
Marc|31|
Susan|54|
Karin|21|

Sheet2
=====
Name|profession|state
Karin|doctor|tx
John|teacher|tx
Susan|manager|pa
Marc|shoe salesman|tx

Regards,

Mark

 

[wideboydixon]

I hope MickG is OK with this but I adapted his code slightly to cater for three columns:

Sub MG06Feb28_WBD()
Dim Rng As Range, Dn As Range, n As Long, Dic As Object, ray As Variant
With Sheets("Sheet2")
    ray = .Range("A1").CurrentRegion.Resize(, 3)
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For n = 2 To UBound(ray, 1)
    Dic(ray(n, 1)) = n
Next
With Sheets("Sheet1")
    Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
    For Each Dn In Rng
        If Dic.exists(Dn.Value) Then
            Dn.Offset(, 2) = ray(Dic(Dn.Value), 2)
            Dn.Offset(, 3) = ray(Dic(Dn.Value), 3)
        End If
    Next Dn
End With
End Sub

Instead of storing the value in the dictionary, it stores the row. I've also re-used the array to retrieve the values (since it was just lying around anyway ...)

WBD

 

[Mark Moscosa]

WOW WBD, thanks for the incredibly fast response. I re edited my lines and it is working! I don't understand Ubound function, for example. For the explanation that you gave about the array, the syntax made more sense.


Have a great day! Cheers from Mexico, amigo!

Mark Moscosa

I hope MickG is OK with this but I adapted his code slightly to cater for three columns:

Sub MG06Feb28_WBD()
Dim Rng As Range, Dn As Range, n As Long, Dic As Object, ray As Variant
With Sheets("Sheet2")
    ray = .Range("A1").CurrentRegion.Resize(, 3)
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For n = 2 To UBound(ray, 1)
    Dic(ray(n, 1)) = n
Next
With Sheets("Sheet1")
    Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
    For Each Dn In Rng
        If Dic.exists(Dn.Value) Then
            Dn.Offset(, 2) = ray(Dic(Dn.Value), 2)
            Dn.Offset(, 3) = ray(Dic(Dn.Value), 3)
        End If
    Next Dn
End With
End Sub

Instead of storing the value in the dictionary, it stores the row. I've also re-used the array to retrieve the values (since it was just lying around anyway ...)

WBD

 

[nigelandrewfoster]

I hope MickG is OK with this but I adapted his code slightly to cater for three columns:

Sub MG06Feb28_WBD()
Dim Rng As Range, Dn As Range, n As Long, Dic As Object, ray As Variant
With Sheets("Sheet2")
    ray = .Range("A1").CurrentRegion.Resize(, 3)
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For n = 2 To UBound(ray, 1)
    Dic(ray(n, 1)) = n
Next
With Sheets("Sheet1")
    Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
    For Each Dn In Rng
        If Dic.exists(Dn.Value) Then
            Dn.Offset(, 2) = ray(Dic(Dn.Value), 2)
            Dn.Offset(, 3) = ray(Dic(Dn.Value), 3)
        End If
    Next Dn
End With
End Sub

Instead of storing the value in the dictionary, it stores the row. I've also re-used the array to retrieve the values (since it was just lying around anyway ...)

WBD

This is excellent - and I didn't know you could use the dictionary for multiple columns. I just adapted this by storing the lookup values and tables in arrays rather than ranges: this speeds up execution by a factor of about 30 in my tests:

Sub MG06Feb28_WBD()

    Dim dblStart As Double
    Dim oDictionary As Object
    Dim rngIndex As Range
    Dim rngLookupValue As Range
    Dim avarLookupTable As Variant
    Dim avarIndex() As Variant
    Dim avarResults() As Variant
    Dim i As Long
    
    dblStart = Timer
    
    Application.ScreenUpdating = False
    
    With Sheets("Lookup in This Table")
        avarLookupTable = .Range("A1").CurrentRegion.Resize(, 10)
    End With
    
    Set oDictionary = CreateObject("Scripting.Dictionary")
    oDictionary.CompareMode = vbTextCompare
    
    For i = 2 To UBound(avarLookupTable, 1)
        oDictionary(avarLookupTable(i, 1)) = i
    Next
    
    With Sheets("Table to Complete")
        avarIndex = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp)).Value
    
        ReDim avarResults(UBound(avarIndex()), 2)
        
        For i = 1 To UBound(avarResults)
            If oDictionary.Exists(avarIndex(i, 1)) Then
                avarResults(i, 1) = avarLookupTable(oDictionary(avarIndex(i, 1)), 5)
                avarResults(i, 2) = avarLookupTable(oDictionary(avarIndex(i, 1)), 6)
            End If
        Next
    
        .[c2:d2].Resize(UBound(avarResults)).Value = avarResults
    
    End With
    
    Application.ScreenUpdating = True
    
    Debug.Print "That took " & (Timer - dblStart) & " seconds"
    
End Sub

 

[kevin9999]

This is excellent - and I didn't know you could use the dictionary for multiple columns. I just adapted this by storing the lookup values and tables in arrays rather than ranges: this speeds up execution by a factor of about 30 in my tests:

Sub MG06Feb28_WBD()

    Dim dblStart As Double
    Dim oDictionary As Object
    Dim rngIndex As Range
    Dim rngLookupValue As Range
    Dim avarLookupTable As Variant
    Dim avarIndex() As Variant
    Dim avarResults() As Variant
    Dim i As Long
   
    dblStart = Timer
   
    Application.ScreenUpdating = False
   
    With Sheets("Lookup in This Table")
        avarLookupTable = .Range("A1").CurrentRegion.Resize(, 10)
    End With
   
    Set oDictionary = CreateObject("Scripting.Dictionary")
    oDictionary.CompareMode = vbTextCompare
   
    For i = 2 To UBound(avarLookupTable, 1)
        oDictionary(avarLookupTable(i, 1)) = i
    Next
   
    With Sheets("Table to Complete")
        avarIndex = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp)).Value
   
        ReDim avarResults(UBound(avarIndex()), 2)
       
        For i = 1 To UBound(avarResults)
            If oDictionary.Exists(avarIndex(i, 1)) Then
                avarResults(i, 1) = avarLookupTable(oDictionary(avarIndex(i, 1)), 5)
                avarResults(i, 2) = avarLookupTable(oDictionary(avarIndex(i, 1)), 6)
            End If
        Next
   
        .[c2:d2].Resize(UBound(avarResults)).Value = avarResults
   
    End With
   
    Application.ScreenUpdating = True
   
    Debug.Print "That took " & (Timer - dblStart) & " seconds"
   
End Sub

@nigelandrewfoster just out of curiosity, how fast was the Dictionary method, and over how many rows of data?

 

[nigelandrewfoster]

My macro

@nigelandrewfoster just out of curiosity, how fast was the Dictionary method, and over how many rows of data?

My macro looked up 13,895 values in a table of 7,994 values, returning and storing lookups in an array from 6 different columns. It took 0.533 seconds.