VBA - How to get a drop down when more than one value matches

[Sarath Karanam]

Hi,

I'm trying this scenario without any luck so far.

I have a set of values in "Sheet1" which I have to vlookup from 2 other sheets using a macro.

Sheet1:

Book Title	Week Number	Name
Book 1
Book 4

<tbody>
</tbody>

Sheet2:

Book Title	Week Number	Name
Book 1	Week 1	AB
Book 2	Week 2	CD
Book 3	Week 3	EF
Book 4	Week 4	GH

<tbody>
</tbody>

Sheet3:

Book Title	Week Number	Name
Book 1	Week 3	GH
Book 3	Week 1	CD

<tbody>
</tbody>

Here, I need to check if any Book from "Sheet1" is matching with Books of "Sheet2" and "Sheet3".

And, if it matches, I need both the results in the following way.

In "Sheet1" beside "Book 1" I need a drop down with both "Week 1" and "Week 3".

When I select "Week 1" from the drop down, I should get "AB" in the "Name" column.

When I select "Week 3" from the drop down, I should get "GH" in the "Name" column.


For "Book 4" in "Sheet1" it should just say "Week 4" and "GH" in the consecutive columns as those are the only values matching.


I'm not sure if this is possible. Can someone please help me.


Regards,
Sarath Karanam

 

[MickG]

Try this:-
Place in sheet1 worksheet module.

Option Explicit
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Rng1 [COLOR="Navy"]As[/COLOR] Range
Private [COLOR="Navy"]Sub[/COLOR] Worksheet_Activate()
[COLOR="Navy"]Dim[/COLOR] Dn      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] n       [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng2    [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rng3    [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] shts
[COLOR="Navy"]Dim[/COLOR] nRng    [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Q
[COLOR="Navy"]With[/COLOR] Sheets("sheet1")
[COLOR="Navy"]Set[/COLOR] Rng1 = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
Rng1.Offset(, 2).ClearContents
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Sheets("sheet2")
[COLOR="Navy"]Set[/COLOR] Rng2 = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Sheets("sheet3")
[COLOR="Navy"]Set[/COLOR] Rng3 = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
shts = Array(Rng2, Rng3)
[COLOR="Navy"]For[/COLOR] n = 0 To 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] shts(n)
ReDim ray(1 To Rng2.Count + Rng3.Count, 1 To 2)
[COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        ray(1, 1) = Dn.Offset(, 1)
        ray(1, 2) = Dn.Offset(, 2)
        Dic.Add Dn.Value, Array(ray, 1)
    [COLOR="Navy"]Else[/COLOR]
        Q = Dic.Item(Dn.Value)
            Q(1) = Q(1) + 1
            Q(0)(Q(1), 1) = Dn.Offset(, 1)
            Q(0)(Q(1), 2) = Dn.Offset(, 2)
        Dic.Item(Dn.Value) = Q
    [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Dim[/COLOR] k
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng1
    [COLOR="Navy"]If[/COLOR] Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        c = c + 2
        Cells(1, c + 25).Resize(Dic.Item(Dn.Value)(1), 2) = Dic.Item(Dn.Value)(0)
        [COLOR="Navy"]Set[/COLOR] nRng = Cells(1, c + 25).Resize(Dic.Item(Dn.Value)(1))
        Range(Dn.Offset(, 1).Address).Select
            [COLOR="Navy"]With[/COLOR] Selection.Validation
                .Delete
                .Add Type:=xlValidateList, Formula1:="=" & nRng.Address & ""
            [COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Private [COLOR="Navy"]Sub[/COLOR] Worksheet_Change(ByVal Target [COLOR="Navy"]As[/COLOR] Range)
[COLOR="Navy"]Dim[/COLOR] Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] wRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] wRng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).Offset(, 1)
        [COLOR="Navy"]If[/COLOR] Not Intersect(wRng, Target) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]For[/COLOR] Num = 1 To Dic.Item(Target.Offset(, -1).Value)(1)
                [COLOR="Navy"]If[/COLOR] Target = Dic.Item(Target.Offset(, -1).Value)(0)(Num, 1) [COLOR="Navy"]Then[/COLOR]
                    Target.Offset(, 1) = Dic.Item(Target.Offset(, -1).Value)(0)(Num, 2)
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Next[/COLOR] Num
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Sarath Karanam]

Hi Mick,

Thank you very much. It really helped.


Regards,
Sarath Karanam