VBA macro to replicate rows when multiple match is found in vlookup

[vasanthr19]

Hi I have data in two spreadsheets as below


Sheet 1

Col1 Col2

AAA 01
BBB 02
CCC 01
DDD 03



Sheet 2
Col1 Col2
01 X11
01 X12
02 Y11
02 Y12
02 Y13
03 Z11

I want to match col2 in sheet 1 with Col1 in sheet2 and whenever a match happens i need the col2 in sheet2 added to sheet 1. If multiple match is found i need the row in sheet1 to be replicated and added with additional match

So for above data
Col1 Col2 Col3
AAA 01 X11
AAA 01 X12
BBB 02 Y11
BBB 02 Y12
BBB 02 Y13
CCC 01 X11
CCC 01 X12
DDD 03 Z11

There will be always a match in col2 of sheet1 and col1 of sheet2. Can you please help me on how to achieve this

 

[MickG]

Try this, Results on sheet 3 starting "A2":-
Based on your Data in sheet1/2 starts Row 2.

[COLOR="Navy"]Sub[/COLOR] MG21Sep08
[COLOR="Navy"]Dim[/COLOR] Rng1 [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nn [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng2 [COLOR="Navy"]As[/COLOR] Range, Dt1 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Dt2 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, K [COLOR="Navy"]As[/COLOR] Variant, P [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Sp1 [COLOR="Navy"]As[/COLOR] Variant, Sp2 [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng1 = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    [COLOR="Navy"]Set[/COLOR] Rng2 = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
Ray = Array(Rng1, Rng2)
    [COLOR="Navy"]For[/COLOR] Ac = 0 To 1
         [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Ray(Ac)
                [COLOR="Navy"]If[/COLOR] Ac = 0 [COLOR="Navy"]Then[/COLOR]
                    Dt1 = Dn.Offset(, -1).Value
                [COLOR="Navy"]Else[/COLOR]
                    Dt2 = Dn.Offset(, 1).Value
                [COLOR="Navy"]End[/COLOR] If
           
                [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                    .Add Dn.Value, Array(Dt1, Dt2)
                [COLOR="Navy"]Else[/COLOR]
                    Q = .Item(Dn.Value)
                        [COLOR="Navy"]If[/COLOR] Ac = 0 [COLOR="Navy"]Then[/COLOR] Q(0) = IIf(Q(0) = "", Dt1, Q(0) & "," & Dt1)
                        [COLOR="Navy"]If[/COLOR] Ac = 1 [COLOR="Navy"]Then[/COLOR] Q(1) = IIf(Q(1) = "", Dt2, Q(1) & "," & Dt2)
                    .Item(Dn.Value) = Q
                [COLOR="Navy"]End[/COLOR] If
         [COLOR="Navy"]Next[/COLOR] Dn
    [COLOR="Navy"]Next[/COLOR] Ac
ReDim Ray(1 To Rng1.Count + Rng2.Count, 1 To 3)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    Sp1 = Split(.Item(K)(0), ",")
    Sp2 = Split(.Item(K)(1), ",")
        [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp1)
            [COLOR="Navy"]For[/COLOR] nn = 0 To UBound(Sp2)
                c = c + 1
                Ray(c, 1) = Sp1(n)
                Ray(c, 2) = K
                Ray(c, 3) = Sp2(nn)
            [COLOR="Navy"]Next[/COLOR] nn
        [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] K
Sheets("Sheet3").Range("A2").Resize(c, 3) = Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick