Index Duplicates to a column

[HockeyDiablo]

I have a list of phones with names

[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]111-111-1111
[/TD]
[TD]John Doe
[/TD]
[/TR]
[TR]
[TD]111-111-1111[/TD]
[TD]Jane Doe[/TD]
[/TR]
[TR]
[TD]222-222-2222[/TD]
[TD]Scott Johnson[/TD]
[/TR]
[TR]
[TD]333-333-3333[/TD]
[TD]Dave Murphy[/TD]
[/TR]
[TR]
[TD]333-333-3333[/TD]
[TD]Pat Keesel[/TD]
[/TR]
[TR]
[TD]333-333-3333[/TD]
[TD]Josh Vanty[/TD]
[/TR]
</tbody>[/TABLE]


I have removed number duplicates and would like the following results.

[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]111-111-111[/TD]
[TD]John Doe[/TD]
[TD]Jane Doe[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]222-222-2222[/TD]
[TD]Scott Johnson[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]333-333-3333[/TD]
[TD]Dave Murphy[/TD]
[TD]Pat Keesel[/TD]
[TD]Josh Vanty[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


Index or match, offset??

 

[MickG]

Try this:-
Data sheet 1, Results sheet2.

[COLOR="Navy"]Sub[/COLOR] MG05Aug50
[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] C [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
ReDim Ray(1 To Rng.Count, 1 To 2)
[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]
        n = n + 1
        Ray(n, 1) = Dn.Value: Ray(n, 2) = Dn.Offset(, 1).Value
        .Add Dn.Value, Array(n, 2)
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(Dn.Value)
            Q(1) = Q(1) + 1
            [COLOR="Navy"]If[/COLOR] UBound(Ray, 2) < Q(1) [COLOR="Navy"]Then[/COLOR] ReDim Preserve Ray(1 To Rng.Count, 1 To Q(1))
            Ray(Q(0), Q(1)) = Dn.Offset(, 1).Value
        .Item(Dn.Value) = Q
   [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
C = .Count
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(C, UBound(Ray, 2))
    .Value = Ray
    .Columns.AutoFit
    .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick