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

NAme	Car
phil	Audi
andy	Audi
jack	Audi
tom	BMW
tim	BMW

<tbody>
</tbody>

 

[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