Vlookup alternative in vba

R

rohan85

Board Regular
Joined
Jun 27, 2013
Messages
81
hi, i have data ids in sheet1 in column a i want to lookup the ids in column a in sheet2 from a to e. what can i use apart from vlookup in vba i would appreciate your help please.

sheet1 sheet2

column a column g column a column e

123 ? 123 rr
234 ? 234 tt
567 ? 567 uu


i have the code which i got from internet but could not figure out how to plug in if you could assist please.


Code: 
Sub test() 
    Dim a, i As Long 
    a = Sheets("sheet2").Range("a1").CurrentRegion.Resize(, 2).Value 
    With CreateObject("Scripting.Dictionary") 
        For i = 2 To UBound(a, 1) 
            .Item(a(i, 1)) = a(i, 2) 
        Next 
        a = Sheets("sheet1").Range("a1").CurrentRegion.Resize(, 3).Value 
        a(1, 3) = "Supplier Name" 
        For i = 2 To UBound(a, 1) 
            If .exists(a(i, 2)) Then a(i, 3) = .Item(a(i, 2)) 
        Next 
    End With 
    Sheets("sheet1").Range("a1").CurrentRegion.Resize(, 3).Value = a 
End Sub
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Sort by date Sort by votes
The above code is using a Scripting Dictionary to create a unique list of values.

If your data looks like this:


Book1
ABCDE
1IDMyVal1MyVal2MyVal3MyVal4
21a1b1c1d1
32a2b2c2d2
43a3b3c3d3
54a4b4c4d4
65a5b5c5d5
76a6b6c6d6
87a7b7c7d7
98a8b8c8d8
Sheet2



Book1
ABCDE
1IDMyVal1MyVal2Myval3MyVal4
22
31
43
55
67
Sheet1


You can use this code as an example of how to load multiple items into the dictionary key and then do a "Vlookup" with the dictionary:
Code: 
[COLOR=#0000ff]Sub [/COLOR][COLOR=#000000]Te[/COLOR]st()
    
    [COLOR=#0000ff] Dim[/COLOR] d [COLOR=#0000ff]As Object[/COLOR]
    [COLOR=#0000ff] Dim[/COLOR] i [COLOR=#0000ff]As Long[/COLOR]
  [COLOR=#0000ff]   Dim[/COLOR] myKey [COLOR=#0000ff]As String[/COLOR]
    [COLOR=#0000ff] Dim[/COLOR] x [COLOR=#0000ff]As Integer[/COLOR]
  [COLOR=#0000ff]   Dim [/COLOR]myLookup(0 [COLOR=#0000ff]To[/COLOR] 3) [COLOR=#0000ff]As String[/COLOR]
  [COLOR=#0000ff]   Dim[/COLOR] cll A[COLOR=#0000ff]s [/COLOR]Range
              
     lr = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row [COLOR=#008000]'Define Last Row[/COLOR]
   [COLOR=#0000ff]  Set [/COLOR]d = CreateObject("scripting.Dictionary")
     d.CompareMode = 1
[COLOR=#008000]     
     'Write Values into the Dictionary[/COLOR]
  [COLOR=#0000ff]   For[/COLOR] i = 2 [COLOR=#0000ff]To[/COLOR] lr
         For x = 0 [COLOR=#0000ff]To[/COLOR] 3
            myLookup(x) = Sheets("Sheet2").Cells(i, x + 2)
      [COLOR=#0000ff]   Next [/COLOR]x
         myKey = Sheets("Sheet2").Cells(i, 1)
         d.Add myKey, myLookup
   [COLOR=#0000ff]  Next[/COLOR] i
    
[COLOR=#008000]     'Retrieve Values from dictionary[/COLOR]
[COLOR=#0000ff]     For Each [/COLOR]cll [COLOR=#0000ff]In [/COLOR]Sheets("Sheet1").Range("A2:A6")
        myKey = cll.Value
        cll.Offset(, 1).Value = d(myKey)(0)
        cll.Offset(, 2).Value = d(myKey)(1)
        cll.Offset(, 3).Value = d(myKey)(2)
        cll.Offset(, 4).Value = d(myKey)(3)
    [COLOR=#0000ff] Next[/COLOR] cll


[COLOR=#0000ff]End Sub[/COLOR]


Result:


Book1
ABCDE
1IDMyVal1MyVal2Myval3MyVal4
22a2b2c2d2
31a1b1c1d1
43a3b3c3d3
55a5b5c5d5
67a7b7c7d7
Sheet1



Another option is to use the .Find method of the range object...
 
Upvote 0
mrmmickle1 said:
The above code is using a Scripting Dictionary to create a unique list of values.

If your data looks like this:

ABCDE
1IDMyVal1MyVal2MyVal3MyVal4
21a1b1c1d1
32a2b2c2d2
43a3b3c3d3
54a4b4c4d4
65a5b5c5d5
76a6b6c6d6
87a7b7c7d7
98a8b8c8d8

<tbody>
</tbody>
Sheet2​



ABCDE
1IDMyVal1MyVal2Myval3MyVal4
22
31
43
55
67

<tbody>
</tbody>
Sheet1​



You can use this code as an example of how to load multiple items into the dictionary key and then do a "Vlookup" with the dictionary:
Code: 
[COLOR=#0000ff]Sub [/COLOR][COLOR=#000000]Te[/COLOR]st()
    
    [COLOR=#0000ff] Dim[/COLOR] d [COLOR=#0000ff]As Object[/COLOR]
    [COLOR=#0000ff] Dim[/COLOR] i [COLOR=#0000ff]As Long[/COLOR]
  [COLOR=#0000ff]   Dim[/COLOR] myKey [COLOR=#0000ff]As String[/COLOR]
    [COLOR=#0000ff] Dim[/COLOR] x [COLOR=#0000ff]As Integer[/COLOR]
  [COLOR=#0000ff]   Dim [/COLOR]myLookup(0 [COLOR=#0000ff]To[/COLOR] 3) [COLOR=#0000ff]As String[/COLOR]
  [COLOR=#0000ff]   Dim[/COLOR] cll A[COLOR=#0000ff]s [/COLOR]Range
              
     lr = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row [COLOR=#008000]'Define Last Row[/COLOR]
   [COLOR=#0000ff]  Set [/COLOR]d = CreateObject("scripting.Dictionary")
     d.CompareMode = 1
[COLOR=#008000]     
     'Write Values into the Dictionary[/COLOR]
  [COLOR=#0000ff]   For[/COLOR] i = 2 [COLOR=#0000ff]To[/COLOR] lr
         For x = 0 [COLOR=#0000ff]To[/COLOR] 3
            myLookup(x) = Sheets("Sheet2").Cells(i, x + 2)
      [COLOR=#0000ff]   Next [/COLOR]x
         myKey = Sheets("Sheet2").Cells(i, 1)
         d.Add myKey, myLookup
   [COLOR=#0000ff]  Next[/COLOR] i
    
[COLOR=#008000]     'Retrieve Values from dictionary[/COLOR]
[COLOR=#0000ff]     For Each [/COLOR]cll [COLOR=#0000ff]In [/COLOR]Sheets("Sheet1").Range("A2:A6")
        myKey = cll.Value
        cll.Offset(, 1).Value = d(myKey)(0)
        cll.Offset(, 2).Value = d(myKey)(1)
        cll.Offset(, 3).Value = d(myKey)(2)
        cll.Offset(, 4).Value = d(myKey)(3)
    [COLOR=#0000ff] Next[/COLOR] cll


[COLOR=#0000ff]End Sub[/COLOR]


Result:

ABCDE
1IDMyVal1MyVal2Myval3MyVal4
22a2b2c2d2
31a1b1c1d1
43a3b3c3d3
55a5b5c5d5
67a7b7c7d7

<tbody>
</tbody>
Sheet1​




Another option is to use the .Find method of the range object...
Click to expand...

....
 
Last edited:
Upvote 0
Thank you so much for your reply its working fine just one question for this line

For Each cll In Sheets("Sheet1").Range("A2:A6") i have increased the range from a6 to a5000 but the error pops up type mismatch how can i stop that. Thanks again.
 
Upvote 0
What does your modified code look like? Can you please provide a sample?

Did you remember to declare the cll variable as a range:
Code: 
[COLOR=#0000ff]Dim[/COLOR] cll [COLOR=#0000ff]As[/COLOR] Range
 
Last edited:
Upvote 0
rohan85 said:
Thank you so much for your reply its working fine just one question for this line

For Each cll In Sheets("Sheet1").Range("A2:A6") i have increased the range from a6 to a5000 but the error pops up type mismatch how can i stop that. Thanks again.
Click to expand...

Hi Sir,

here is the modified code

Code: 
Sub Test()
    
     Dim d As Object
     Dim i As Long
     Dim myKey As String
     Dim x As Integer
     Dim myLookup(0 To 3) As String
     Dim cll As Range
              
     lr = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row 'Define Last Row
     Set d = CreateObject("scripting.Dictionary")
     d.CompareMode = 1
     
     'Write Values into the Dictionary
     For i = 2 To lr
         For x = 0 To 3
            myLookup(x) = Sheets("Sheet2").Cells(i, x + 2)
         Next x
         myKey = Sheets("Sheet2").Cells(i, 1)
         d.Add myKey, myLookup
     Next i
    
     'Retrieve Values from dictionary
     For Each cll In Sheets("Sheet1").Range("A2:A5000")
        myKey = cll.Value
       
        cll.Offset(, 4).Value = d(myKey)(3)
      
     Next cll
End Sub
 
Last edited:
Upvote 0
I just ran a test using your posted code and the below dummy data:


Book1
ABCDE
1IDMyVal1MyVal2MyVal3MyVal4
21a1b1c1d1
32a2b2c2d2
43a3b3c3d3
54a4b4c4d4
65a5b5c5d5
76a6b6c6d6
87a7b7c7d7
98a8b8c8d8
Sheet2


My Result was like this.... all the way through A5000

Book1
ABCDE
1IDTestCol
21d1
31d1
42d2
52d2
63d3
73d3
84d4
94d4
105d5
115d5
126d6
136d6
Sheet1


I can't reproduce the error.
 
Upvote 0
mrmmickle1 said:
I just ran a test using your posted code and the below dummy data:

ABCDE
1IDMyVal1MyVal2MyVal3MyVal4
21a1b1c1d1
32a2b2c2d2
43a3b3c3d3
54a4b4c4d4
65a5b5c5d5
76a6b6c6d6
87a7b7c7d7
98a8b8c8d8

<colgroup><col style="width: 25pxpx"><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>
Sheet2​



My Result was like this.... all the way through A5000
ABCDE
1IDTestCol
21d1
31d1
42d2
52d2
63d3
73d3
84d4
94d4
105d5
115d5
126d6
136d6

<colgroup><col style="width: 25pxpx"><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>
Sheet1​



I can't reproduce the error.
Click to expand...

---
 
Upvote 0
Hi Sir Thanks again i meant till last used row i was increasing the range but there is no data, here is the code for your reference but it gives me error type mismatch
Code: 
Sub Test()
    
     Dim d As Object
     Dim i As Long
     Dim myKey As String
     Dim x As Integer
     Dim myLookup(0 To 3) As String
     Dim cll As Range
              
     lr = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row 'Define Last Row
     Set d = CreateObject("scripting.Dictionary")
     d.CompareMode = 1
     
     'Write Values into the Dictionary
     For i = 2 To lr
         For x = 0 To 3
            myLookup(x) = Sheets("Sheet2").Cells(i, x + 2)
         Next x
         myKey = Sheets("Sheet2").Cells(i, 1)
         d.Add myKey, myLookup
     Next i
    
     'Retrieve Values from dictionary
     
     Dim last As Long
     last = Worksheets("Sheet1").Cells.Find(What:="*", SearchOrder:=xlRows, _
     SearchDirection:=xlPrevious, LookIn:=xlValues).Row
     For Each cll In Sheets("Sheet1").Range("A2" & last)
        myKey = cll.Value
   
        cll.Offset(, 4).Value = d(myKey)(3)
      
     Next cll




End Sub
 
Last edited:
Upvote 0
Change this:

Code: 
  For Each cll In Sheets("Sheet1").Range("A2[COLOR=#ff0000][B]:A[/B][/COLOR]" & last)
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
Find, lookup, match - based on 2 separate criteria.
Replies
4
Views
204
Peter_SSs
Peter_SSs
R
  • Question
VBA Check if value in Sheet1 exists in Sheet2 then copy specific cells from Sheet2 into Sheet1
2
Replies
13
Views
760
dermie_72
D
C
  • Question
VLOOKUP 255 Character Limit - formula alternatives?
Replies
4
Views
330
Joe4
Joe4
J
  • Question
INDEX MATCH from two sheets onto third sheet?
Replies
1
Views
116
etaf
etaf
W
  • Solved
Dynamic dropdown list based on database
Replies
3
Views
207
Winnetou
W

Forum statistics

Threads
1,215,254
Messages
6,123,893
Members
449,132
Latest member
Rosie14

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