vba help - extract duplicate via vlookup/dictionary

[Mallesh23]

Hi Team,

I want to apply vlookup and get matching value.
But if there are duplicate matching value I want to show all by using Seperator.


Below is a Table
Input Column A and B.
with expected output Column E and F. how to achieve below task using dictionary or any other method.

Book1
	A	B	C	D	E	F
1	Name	Bank Ac Name		Expected Output:=>	Name	Bank Ac Name
2	Sachin	SBI			Sachin	SBI/HDFC
3	Dhoni	SBI			Dhoni	SBI/JP Morgan
4	Sachin	HDFC			Sachin	SBI/HDFC
5	Kohli	ICICI			Kohli	ICICI/SWISS/Bank of America
6	Gayle	SWISS			Gayle	SWISS
7	Peterson	HSBC			Peterson	HSBC
8	Ponting	Bank of America			Ponting	Bank of America
9	Dhoni	JP Morgan			Dhoni	SBI/JP Morgan
10	Jaysurya	Bank of China			Jaysurya	Bank of China/HSBC
11	Jaysurya	HSBC			Jaysurya	Bank of China/HSBC
12	Kohli	SWISS			Kohli	ICICI/SWISS/Bank of America
13	Kohli	Bank of America			Kohli	ICICI/SWISS/Bank of America
Sheet1

Thanks
mg

 

[Fluff]

What have you already tried?

 

[YasserKhalil]

Try this

Sub Test()
    Dim a, i As Long
    a = Sheets("Sheet1").Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .Exists(a(i, 1)) Then
                a(.Count + 1, 1) = a(i, 1): a(.Count + 1, 2) = Empty
                .Item(a(i, 1)) = Array(.Count + 1, CreateObject("Scripting.Dictionary"))
                .Item(a(i, 1))(1).CompareMode = 1
            End If
            If Not .Item(a(i, 1))(1).Exists(a(i, 2)) Then
                a(.Item(a(i, 1))(0), 2) = a(.Item(a(i, 1))(0), 2) & IIf(a(.Item(a(i, 1))(0), 2) <> "", " / ", "") & a(i, 2)
                .Item(a(i, 1))(1)(a(i, 2)) = Empty
            End If
        Next i
        i = .Count
    End With
    Sheets("Sheet1").Cells(7).Resize(i, 2) = a
End Sub

 

[Mallesh23]

Hi Fluff,

This is my attempted code, It bring only first Match.

Sub Dict_array()
    
    Dim dict As New Scripting.dictionary
    Dim arr As Variant
    Dim i As Long
    Dim ary As Variant
   
    arr = Range("A1").CurrentRegion.Value
   
    'Store in Dictionary
    With dict
        For i = LBound(arr, 1) To UBound(arr, 1)
            If Not .Exists(arr(i, 1)) Then
                .Add (arr(i, 1)), arr(i, 2)
            End If
        Next i
   
       ary = Range("E2:E13").Value2
     
       For i = LBound(ary, 1) To UBound(ary, 1)
             ary(i, 1) = .Item(ary(i, 1))
       Next i
   
    End With
    Range("f2:f13").Value = ary
End Sub

Thanks
mg

 

[Fluff]

Ok, try it like

Sub Dict_array()
    
    Dim dict As New Scripting.dictionary
    Dim arr As Variant
    Dim i As Long
    Dim ary As Variant
   
    arr = Range("A1").CurrentRegion.Value
   
    'Store in Dictionary
    With dict
        For i = LBound(arr, 1) To UBound(arr, 1)
            If Not .Exists(arr(i, 1)) Then
                .Add (arr(i, 1)), arr(i, 2)
            Else
                .Item(arr(i, 1)) = .Item(arr(i, 1)) & "/" & arr(i, 2)
            End If
        Next i
   
       ary = Range("E2:E13").Value2
     
       For i = LBound(ary, 1) To UBound(ary, 1)
             ary(i, 1) = .Item(ary(i, 1))
       Next i
   
    End With
    Range("f2:f13").Value = ary
End Sub

 

[Mallesh23]

Hi Fluff and Yasir,

Perfect ! it worked , Millions of Thanks both of you for your help. ?

I will choose Fluffs answer that was I am expecting in current task.
Yasir - your answer is also correct you have taken unique Names, I was looking all. Thanks



Thanks
mg

 

[Fluff]

Glad we could help & thanks for the feedback.