Vlookup with multiple occurances of a value

Hyp40

New Member
Joined
Apr 9, 2019
Messages
16
It is a list of postcodes, so yes, I understand the problem. Could the extra results go at the bottom of the list, or in the next column perhaps?
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
32,243
Office Version
365
Platform
Windows
Ok, how about
Code:
Sub Hyp40()
   Dim Cl As Range
   Dim Ws1 As Worksheet, Ws2 As Worksheet
   Dim Sp As Variant
   Dim i As Long
   
   Set Ws1 = Sheets("[COLOR=#ff0000]Master[/COLOR]")
   Set Ws2 = Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")
   With CreateObject("Scripting.dictionary")
      For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
         Sp = Split(Cl.Value, ",")
         For i = 0 To UBound(Sp)
            If Not .Exists(Trim(Sp(i))) Then
               .Add Sp(i), Cl.Offset(, 1).Resize(, 3)
            Else
               Set .Item(Trim(Sp(i))) = Union(.Item(Trim(Sp(i))), Cl.Offset(, 1).Resize(, 3))
            End If
         Next i
      Next Cl
      For Each Cl In Ws2.Range("A2", Ws2.Range("A" & Rows.Count).End(xlUp))
         If .Exists(Cl.Value) Then
            Ws2.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(.Item(Cl.Value).Count / 3, 1).Value = Cl.Value
            .Item(Cl.Value).Copy Ws2.Range("C" & Rows.Count).End(xlUp).Offset(1)
         End If
      Next Cl
   End With
End Sub
Change sheet names to suit
 

Hyp40

New Member
Joined
Apr 9, 2019
Messages
16
Wow thank you Fluff, that certainly solves the problem. Amazing.
I have been struggling for days with this. Thank you so much.
Now to see if I can work out what the code is doing!
 
Last edited:

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
32,243
Office Version
365
Platform
Windows
It already does that ;)
 

Hyp40

New Member
Joined
Apr 9, 2019
Messages
16
Sorry Fluff - I was so excited that I didn't check the output properly. It does it all! I amended my reply - but not soon enough.
Thank you
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
32,243
Office Version
365
Platform
Windows
Glad to help & thanks for the feedback
 

Hyp40

New Member
Joined
Apr 9, 2019
Messages
16
Hi Fluff, sorry to trouble you again.
Is there a maximum number of rows I can search on? This works perfectly on my sample data but when I try it on the actual data, I get "Run-time error '457': This key is already associated with an element of this collection". This seems to happen if I have more than 1450 rows in the Master List.
My Master list has 66000 rows and the look up list has around 5000 rows.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
32,243
Office Version
365
Platform
Windows
There was a slight flaw in the code, try
Code:
Sub Hyp40()
   Dim Cl As Range
   Dim Ws1 As Worksheet, Ws2 As Worksheet
   Dim Sp As Variant
   Dim i As Long
   
   Set Ws1 = Sheets("RC")
   Set Ws2 = Sheets("Form")
   With CreateObject("Scripting.dictionary")
      For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
         Sp = Split(Cl.Value, ",")
         For i = 0 To UBound(Sp)
            If Not .Exists(Trim(Sp(i))) Then
               .Add [COLOR=#0000ff]Trim(Sp(i))[/COLOR], Cl.Offset(, 1).Resize(, 3)
            Else
               Set .Item(Trim(Sp(i))) = Union(.Item(Trim(Sp(i))), Cl.Offset(, 1).Resize(, 3))
            End If
         Next i
      Next Cl
      For Each Cl In Ws2.Range("A2", Ws2.Range("A" & Rows.Count).End(xlUp))
         If .Exists(Cl.Value) Then
            Ws2.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(.Item(Cl.Value).Count / 3, 1).Value = Cl.Value
            .Item(Cl.Value).Copy Ws2.Range("C" & Rows.Count).End(xlUp).Offset(1)
         End If
      Next Cl
   End With
End Sub
 

Hyp40

New Member
Joined
Apr 9, 2019
Messages
16
Thank you Fluff. That has worked perfectly. Can't say that I understand the slight difference but you have made my weekend. I'm really grateful :)
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
32,243
Office Version
365
Platform
Windows
If you have data like
PE14 8PS, PE12 0JW
This line
Code:
If Not .Exists(Trim(Sp(i))) Then
will trim the value so it will check for "PE14 8PS" and "PE12 0JW", if the 2nd value didn't exist it would add " PE12 0JW" (note the space at the start) rather than "PE12 0JW"
So the mod I made corrects that problem.
 

Forum statistics

Threads
1,082,063
Messages
5,362,961
Members
400,701
Latest member
drs2911

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top