Vlookup Alternative using Dictionary

S

Super P

New Member
Joined
May 22, 2021
Messages
28
Office Version
  1. 365
Platform
  1. Windows
The code below is the alternative to vlookup.

This lookup then copy values from Column D and E of sheet "Data" to column D and E of sheet "Master" based in the matching values in column A for both worksheets i.e. using 1 criteria only.

Can someone help on how to make the code below to lookup and match 2 criteria i.e. to lookup and match column A and B for both sheets?

Thanks in advance for help...

Option Explicit

Sub VLookup_Alternative()

Dim rng As Range, j As Range, i, lRow As Long, Dict As Object, myArray As Variant

With Sheets("Data")
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
myArray = .Range("A1").Resize(lRow, 4)
Set Dict = CreateObject("scripting.dictionary")
Dict.CompareMode = vbTextCompare
For i = 2 To UBound(myArray, 1)
Dict(myArray(i, 1)) = i
Next
End With

With Sheets("Master")
Set rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
For Each j In rng
If Dict.exists(j.Value2) Then
j.Offset(, 3) = myArray(Dict(j.Value2), 3)
j.Offset(, 4) = myArray(Dict(j.Value2), 4)
End If
Next j
End With

End Sub
 

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
Sort by date Sort by votes
try this ( untested):
VBA Code: 
Option Explicit

Sub VLookup_Alternative()

Dim rng As Variant, j As Long, i, lRow As Long, Dict As Object, myArray As Variant

With Sheets("Data")
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
myArray = .Range("A1").Resize(lRow, 4)
Set Dict = CreateObject("scripting.dictionary")
Dict.CompareMode = vbTextCompare
For i = 2 To UBound(myArray, 1)
Dict(myArray(i, 1) * myArray(i, 2)) = i
Next
End With

With Sheets("Master")
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
rng = .Range("A2").Resize(lRow, 4)
For j = 1 To UBound(rng, 1)
If Dict.exists(rng(j, 1) * rng(j, 2)) Then
rng(j, 3) = myArray(Dict(rng(j, 1) * rng(j, 2)), 3)
rng(j, 4) = myArray(Dict(rng(j, 1) * rng(j, 2)), 4)
End If
Next j
 Range("A2").Resize(lRow, 4) = rng
End With


End Sub
 
Upvote 0
offthelip said:
try this ( untested):
VBA Code: 
Option Explicit

Sub VLookup_Alternative()

Dim rng As Variant, j As Long, i, lRow As Long, Dict As Object, myArray As Variant

With Sheets("Data")
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
myArray = .Range("A1").Resize(lRow, 4)
Set Dict = CreateObject("scripting.dictionary")
Dict.CompareMode = vbTextCompare
For i = 2 To UBound(myArray, 1)
Dict(myArray(i, 1) * myArray(i, 2)) = i
Next
End With

With Sheets("Master")
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
rng = .Range("A2").Resize(lRow, 4)
For j = 1 To UBound(rng, 1)
If Dict.exists(rng(j, 1) * rng(j, 2)) Then
rng(j, 3) = myArray(Dict(rng(j, 1) * rng(j, 2)), 3)
rng(j, 4) = myArray(Dict(rng(j, 1) * rng(j, 2)), 4)
End If
Next j
 Range("A2").Resize(lRow, 4) = rng
End With


End Sub
Click to expand...
@offthelip thanks for the reply, i got runtime error 13 "type mismatch"
 
Upvote 0
Super P said:
@offthelip thanks for the reply, i got runtime error 13 "type mismatch"
Click to expand...
@offthelip, I did change * to & and the code works!

VBA Code: 
Option Explicit

Sub VLookup_Alternative()

Dim rng As Variant, j As Long, i, lRow As Long, Dict As Object, myArray As Variant

With Sheets("TradeData")
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
myArray = .Range("A1").Resize(lRow, 4)
Set Dict = CreateObject("scripting.dictionary")
Dict.CompareMode = vbTextCompare
For i = 2 To UBound(myArray, 1)
Dict(myArray(i, 1) & myArray(i, 2)) = i
Next
End With

With Sheets("MasterData")
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
rng = .Range("A2").Resize(lRow, 4)
For j = 1 To UBound(rng, 1)
If Dict.Exists(rng(j, 1) & rng(j, 2)) Then
rng(j, 3) = myArray(Dict(rng(j, 1) & rng(j, 2)), 3)
rng(j, 4) = myArray(Dict(rng(j, 1) & rng(j, 2)), 4)
End If
Next j
 Range("A2").Resize(lRow, 4) = rng
End With


End Sub
 
Upvote 0
@Super P, I would suggest you also add the leading full stop "." to the last line so that it is still referring to the sheet Master and using the last "with" statement and not the active sheet which may be different.

VBA Code: 
.Range("A2").Resize(lRow, 4) = rng
 
Upvote 0
Super P said:
@offthelip, I did change * to & and the code works!

VBA Code: 
Option Explicit

Sub VLookup_Alternative()

Dim rng As Variant, j As Long, i, lRow As Long, Dict As Object, myArray As Variant

With Sheets("TradeData")
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
myArray = .Range("A1").Resize(lRow, 4)
Set Dict = CreateObject("scripting.dictionary")
Dict.CompareMode = vbTextCompare
For i = 2 To UBound(myArray, 1)
Dict(myArray(i, 1) & myArray(i, 2)) = i
Next
End With

With Sheets("MasterData")
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
rng = .Range("A2").Resize(lRow, 4)
For j = 1 To UBound(rng, 1)
If Dict.Exists(rng(j, 1) & rng(j, 2)) Then
rng(j, 3) = myArray(Dict(rng(j, 1) & rng(j, 2)), 3)
rng(j, 4) = myArray(Dict(rng(j, 1) & rng(j, 2)), 4)
End If
Next j
 Range("A2").Resize(lRow, 4) = rng
End With


End Sub
Click to expand...
@offthelip can you please help if no match found (If Not Dict Exist), can you be able to advise the changes in the code that will pick the values of the last row of the dataset? thanks
 
Upvote 0
Super P said:
@offthelip can you please help if no match found (If Not Dict Exist), can you be able to advise the changes in the code that will pick the values of the last row of the dataset? thanks
Click to expand...
Your requirement is not very clear. What seems most likely is you want lines in Data not in Master added to Master. If that is the case this should work for you.

VBA Code: 
Sub VLookup_Alternative_v02()

    Dim arrMstr As Variant, arrData As Variant
    Dim j As Long, i As Long, lRowData As Long, lRowMstr As Long
    Dim dictData As Object, dictMstr As Object
    Dim dKeyData As Variant
    Dim arrMissing()
    Dim k As Long, m As Long
    
    With Sheets("Data")
        lRowData = .Cells(Rows.Count, 1).End(xlUp).Row
        arrData = .Range("A1").Resize(lRowData, 4)
        Set dictData = CreateObject("scripting.dictionary")
        dictData.CompareMode = vbTextCompare
        For i = 2 To UBound(arrData, 1)
            dictData(arrData(i, 1) & "|" & arrData(i, 2)) = i
        Next
    End With
    
    With Sheets("Master")
        lRowMstr = .Cells(Rows.Count, 1).End(xlUp).Row
        arrMstr = .Range("A2").Resize(lRowMstr, 4)
        Set dictMstr = CreateObject("scripting.dictionary")
        dictMstr.CompareMode = vbTextCompare
        For j = 1 To UBound(arrMstr, 1)
            dictMstr(arrMstr(j, 1) & "|" & arrMstr(j, 2)) = j
            If dictData.exists(arrMstr(j, 1) & "|" & arrMstr(j, 2)) Then
                arrMstr(j, 3) = arrData(dictData(arrMstr(j, 1) & "|" & arrMstr(j, 2)), 3)
                arrMstr(j, 4) = arrData(dictData(arrMstr(j, 1) & "|" & arrMstr(j, 2)), 4)
            End If
        Next j
        .Range("A2").Resize(lRowMstr, 4) = arrMstr
    End With
    
    ReDim arrMissing(1 To dictMstr.Count, 1 To 4)
    
    m = 0
    For Each dKeyData In dictData.keys
        If Not dictMstr.exists(dKeyData) Then
            m = m + 1
            For k = 1 To 4
                arrMissing(m, k) = arrData(dictData(dKeyData), k)
            Next k
        End If
    Next dKeyData
    
    Sheets("Master").Range("A" & lRowMstr + 1).Resize(m, 4) = arrMissing

End Sub
 
Upvote 0
Alex Blakenburg said:
Your requirement is not very clear. What seems most likely is you want lines in Data not in Master added to Master. If that is the case this should work for you.

VBA Code: 
Sub VLookup_Alternative_v02()

    Dim arrMstr As Variant, arrData As Variant
    Dim j As Long, i As Long, lRowData As Long, lRowMstr As Long
    Dim dictData As Object, dictMstr As Object
    Dim dKeyData As Variant
    Dim arrMissing()
    Dim k As Long, m As Long
   
    With Sheets("Data")
        lRowData = .Cells(Rows.Count, 1).End(xlUp).Row
        arrData = .Range("A1").Resize(lRowData, 4)
        Set dictData = CreateObject("scripting.dictionary")
        dictData.CompareMode = vbTextCompare
        For i = 2 To UBound(arrData, 1)
            dictData(arrData(i, 1) & "|" & arrData(i, 2)) = i
        Next
    End With
   
    With Sheets("Master")
        lRowMstr = .Cells(Rows.Count, 1).End(xlUp).Row
        arrMstr = .Range("A2").Resize(lRowMstr, 4)
        Set dictMstr = CreateObject("scripting.dictionary")
        dictMstr.CompareMode = vbTextCompare
        For j = 1 To UBound(arrMstr, 1)
            dictMstr(arrMstr(j, 1) & "|" & arrMstr(j, 2)) = j
            If dictData.exists(arrMstr(j, 1) & "|" & arrMstr(j, 2)) Then
                arrMstr(j, 3) = arrData(dictData(arrMstr(j, 1) & "|" & arrMstr(j, 2)), 3)
                arrMstr(j, 4) = arrData(dictData(arrMstr(j, 1) & "|" & arrMstr(j, 2)), 4)
            End If
        Next j
        .Range("A2").Resize(lRowMstr, 4) = arrMstr
    End With
   
    ReDim arrMissing(1 To dictMstr.Count, 1 To 4)
   
    m = 0
    For Each dKeyData In dictData.keys
        If Not dictMstr.exists(dKeyData) Then
            m = m + 1
            For k = 1 To 4
                arrMissing(m, k) = arrData(dictData(dKeyData), k)
            Next k
        End If
    Next dKeyData
   
    Sheets("Master").Range("A" & lRowMstr + 1).Resize(m, 4) = arrMissing

End Sub
Click to expand...
@Alex Blakenburg many thanks to your help, sorry if did not make my self clear.

If the data input in "Master" has no match in "Data" e.g. Col A & B, Row 3 of Master in screenshot below has no match in Col A & B of "Data", the values to be populated in Col C & D, Row 3 of "Master is Col C & D, last Row (Row 4) of "Data"


1648982914148.png


1648982941534.png
 
Upvote 0
Not sure about the logic of that but see if this does what you are after.
(it is basically @offthelip's code with some tweaks)

VBA Code: 
Sub VLookup_Alternative_v03()

    Dim arrRng As Variant, j As Long, i As Long, lRow As Long, Dict As Object, myArray As Variant
    Dim arrUBound As Long        ' XXX Added
    Dim rng As Range             ' XXX Added
    
    With Sheets("Data")
        lRow = .Cells(Rows.Count, 1).End(xlUp).Row
        myArray = .Range("A1").Resize(lRow, 4)
        Set Dict = CreateObject("scripting.dictionary")
        Dict.CompareMode = vbTextCompare
        For i = 2 To UBound(myArray, 1)
            Dict(myArray(i, 1) & "|" & myArray(i, 2)) = i
        Next
    End With
    
    arrUBound = UBound(myArray)       ' XXX Added
    
    With Sheets("Master")
        lRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rng = .Range("A2:D" & lRow)
        arrRng = rng.Value
        For j = 1 To UBound(arrRng, 1)
            If Dict.exists(arrRng(j, 1) & "|" & arrRng(j, 2)) Then
                arrRng(j, 3) = myArray(Dict(arrRng(j, 1) & "|" & arrRng(j, 2)), 3)
                arrRng(j, 4) = myArray(Dict(arrRng(j, 1) & "|" & arrRng(j, 2)), 4)
            Else
                arrRng(j, 3) = myArray(arrUBound, 3)        ' XXX Added
                arrRng(j, 4) = myArray(arrUBound, 4)        ' XXX Added
            End If
        Next j
        .Range("A2").Resize(UBound(arrRng), 4) = arrRng     ' XXX Changed
    End With

End Sub
 
Upvote 0
Solution
Alex Blakenburg said:
Not sure about the logic of that but see if this does what you are after.
(it is basically @offthelip's code with some tweaks)

VBA Code: 
Sub VLookup_Alternative_v03()

    Dim arrRng As Variant, j As Long, i As Long, lRow As Long, Dict As Object, myArray As Variant
    Dim arrUBound As Long        ' XXX Added
    Dim rng As Range             ' XXX Added
   
    With Sheets("Data")
        lRow = .Cells(Rows.Count, 1).End(xlUp).Row
        myArray = .Range("A1").Resize(lRow, 4)
        Set Dict = CreateObject("scripting.dictionary")
        Dict.CompareMode = vbTextCompare
        For i = 2 To UBound(myArray, 1)
            Dict(myArray(i, 1) & "|" & myArray(i, 2)) = i
        Next
    End With
   
    arrUBound = UBound(myArray)       ' XXX Added
   
    With Sheets("Master")
        lRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rng = .Range("A2:D" & lRow)
        arrRng = rng.Value
        For j = 1 To UBound(arrRng, 1)
            If Dict.exists(arrRng(j, 1) & "|" & arrRng(j, 2)) Then
                arrRng(j, 3) = myArray(Dict(arrRng(j, 1) & "|" & arrRng(j, 2)), 3)
                arrRng(j, 4) = myArray(Dict(arrRng(j, 1) & "|" & arrRng(j, 2)), 4)
            Else
                arrRng(j, 3) = myArray(arrUBound, 3)        ' XXX Added
                arrRng(j, 4) = myArray(arrUBound, 4)        ' XXX Added
            End If
        Next j
        .Range("A2").Resize(UBound(arrRng), 4) = arrRng     ' XXX Changed
    End With

End Sub
Click to expand...
@Alex Blakenburg many thanks, that works like a charm!!! the column B is actually dates, e.g. if I input the date today in "Master", and the last date in the "Data" is yesterday the data will still populate based on the latest date which is yesterday.
 
Upvote 0
You must log in or register to reply here.

Similar threads

JeffGrant
  • Question
Find & Replace is searching whole workbook instead of just the sheet
Replies
7
Views
114
bobsan42
bobsan42
H
  • Question
VBA split file based and send splitted file in separate emails
Replies
0
Views
136
harmless92
H
A
  • Question
VBA to Split Data From an Existing Table into Another Single Worksheet with Header for Each Section
Replies
1
Views
150
John_w
J
R
  • Question
VBA - Space Become Question Mark
Replies
2
Views
683
RudRud
R
S
  • Question
Autofilter in VBA when criteria is has more words separated by a comma in 2 sheets
Replies
0
Views
468
shafiey
S

Forum statistics

Threads
1,214,591
Messages
6,120,425
Members
448,961
Latest member
nzskater

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top