VBA - List from Table (simple-

[rsj88]

I have The following in a table in Cell A1:B6

I have the Car (Audi BMW) listed in cell C1 and D1. And need to obtain all the names under each car. eg tom and tim would be under BMW.

Need this in a VBA code please
[TABLE="width: 500"]
<tbody>[TR]
[TD]NAme[/TD]
[TD]Car[/TD]
[/TR]
[TR]
[TD]phil[/TD]
[TD]Audi[/TD]
[/TR]
[TR]
[TD]andy[/TD]
[TD]Audi[/TD]
[/TR]
[TR]
[TD]jack[/TD]
[TD]Audi[/TD]
[/TR]
[TR]
[TD]tom[/TD]
[TD]BMW[/TD]
[/TR]
[TR]
[TD]tim[/TD]
[TD]BMW[/TD]
[/TR]
</tbody>[/TABLE]

 

[MickG]

Try this for results in columns "C & D"

[COLOR="Navy"]Sub[/COLOR] MG20Feb21
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = Range("B2", Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        ReDim Ray(1 To 1)
        Ray(1) = Dn.Offset(, -1).Value
        .Add Dn.Value, Ray
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(Dn.Value)
        ReDim Preserve Q(1 To UBound(Q) + 1)
        Q(UBound(Q)) = Dn.Offset(, -1).Value
        .Item(Dn.Value) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Ac = 2
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
        Ac = Ac + 1
        Cells(1, Ac) = K
        Cells(2, Ac).Resize(UBound(.Item(K))) = Application.Transpose(.Item(K))
    [COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[rsj88]

thanks mate perfect!!

Try this for results in columns "C & D"

[COLOR=navy]Sub[/COLOR] MG20Feb21
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Q [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Set[/COLOR] Rng = Range("B2", Range("B" & Rows.Count).End(xlUp))
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    [COLOR=navy]If[/COLOR] Not .Exists(Dn.Value) [COLOR=navy]Then[/COLOR]
        ReDim Ray(1 To 1)
        Ray(1) = Dn.Offset(, -1).Value
        .Add Dn.Value, Ray
    [COLOR=navy]Else[/COLOR]
        Q = .Item(Dn.Value)
        ReDim Preserve Q(1 To UBound(Q) + 1)
        Q(UBound(Q)) = Dn.Offset(, -1).Value
        .Item(Dn.Value) = Q
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]Dim[/COLOR] K [COLOR=navy]As[/COLOR] Variant, Ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
Ac = 2
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
        Ac = Ac + 1
        Cells(1, Ac) = K
        Cells(2, Ac).Resize(UBound(.Item(K))) = Application.Transpose(.Item(K))
    [COLOR=navy]Next[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[MickG]

You're welcome