VBA CODE to vlookup and get multiple results

[Wafee]

I have a requirement where there are set of values in A column of sheet1. These values in column A are mapped to multiple values in sheet2 of A and B column. I need a VBA code where it gives me the unquiet list of mapped items in horizontal manner. So the result must reflect in B2, B3, B4 etc. Data starts from A2.

 

[DanteAmor]

You could give examples of what you have and what you expect from the result, use the XL2BB tool to paste cell ranges here, look at my signature.
If they are confidential data, replace them with generic data.

 

[Wafee]

You could give examples of what you have and what you expect from the result, use the XL2BB tool to paste cell ranges here, look at my signature.
If they are confidential data, replace them with generic data.

Hi DanteAmor

Sorry, below is my source data and the output i am expecting. I have a list of DATA ID's in sheet1 and in sheet 2 I have DATA ID's and their categories. Sheet2 might have duplicates and code should be able to consider CATEGORY only once against a DATA ID and number of categories should be limited to 20. which means if DATA ID Starts in A2(Sheet1) then output starts in B2 and should end at T2 or below not more than that.

Sheet2 data.

​

DATA ID​	CATEGORY​
100​	A​
101​	A​
102​	A​
100​	A​
101​	B​
102​	A​
100​	C​
101​	C​
102​	A​

​

Shee1 - Expected output (103 doesn't have any results in sheet2 so it is left out blank)

​

DATA ID​	CAT 1​	CAT 2​	CAT 3​	CAT 4​
100​	A​	C​	​	​
101​	A​	B​	C​	​
102​	A​	​	​	​
103​	​	​	​	​

 

[DanteAmor]

Try this

Sub Vlookup_Values()
  Dim a As Variant, b As Variant, c As Variant
  Dim dic1 As Object, dic2 As Object
  Dim i As Long, j As Long, k As Long, lr As Long, m As Long
  
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  a = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("A" & Rows.Count).End(3)).Value2
  With Sheets("Sheet2")
    lr = .Range("A" & Rows.Count).End(3).Row
    b = .Range("A2:B" & lr).Value2
    m = Evaluate(Replace("=SUMPRODUCT((@<>"""")/COUNTIF(@,@&""""))", "@", .Name & "!B2:B" & lr)) 'unique
  End With
  ReDim c(1 To UBound(a), 1 To m)

  For i = 1 To UBound(a)
    dic1(a(i, 1)) = i & "|" & 1
  Next
  For i = 1 To UBound(b, 1)
    If Not dic2.exists(b(i, 1) & "|" & b(i, 2)) Then
      dic2(b(i, 1) & "|" & b(i, 2)) = b(i, 1)
      If dic1.exists(b(i, 1)) Then
        j = Split(dic1(b(i, 1)), "|")(0)
        k = Split(dic1(b(i, 1)), "|")(1)
        c(j, k) = b(i, 2)
        k = k + 1
        dic1(b(i, 1)) = j & "|" & k
      End If
    End If
  Next
  Sheets("Sheet1").Range("B2").Resize(UBound(c, 1), UBound(c, 2)).Value = c
End Sub