VBA Loop for ordering matching data

[Summerso1]

Hi All,

This should be easy but its not! I am wanting a VBA loop script.

1. which goes down column A and check if there are codes that are the same e.g below the first 4 are the same.
2. from this am wanting to create a new table which copies the code 000000HA once and then the 4 dates after in columns like this:

E F G H I
000000HA 26/02/2014 07/08/2014 13/08/2013 18/08/2014


A B C
[TABLE="width: 295"]
<colgroup><col><col><col></colgroup><tbody>[TR]
[TD]000000HA[/TD]
[TD]665587[/TD]
[TD]13/08/2014[/TD]
[/TR]
[TR]
[TD]000000HB[/TD]
[TD]529853[/TD]
[TD]26/02/2014[/TD]
[/TR]
[TR]
[TD]000000HB[/TD]
[TD]659642[/TD]
[TD]07/08/2014[/TD]
[/TR]
[TR]
[TD]000000HB[/TD]
[TD]668763[/TD]
[TD]18/08/2014[/TD]
[/TR]
[TR]
[TD]000000I5[/TD]
[TD]554083[/TD]
[TD]31/03/2014[/TD]
[/TR]
[TR]
[TD]000000IU[/TD]
[TD]656913[/TD]
[TD]04/08/2014[/TD]
[/TR]
[TR]
[TD]000000KL[/TD]
[TD]500644[/TD]
[TD]22/01/2014[/TD]
[/TR]
[TR]
[TD]000000LN[/TD]
[TD]560331[/TD]
[TD]07/04/2014[/TD]
[/TR]
[TR]
[TD]000000LN[/TD]
[TD]652808[/TD]
[TD]30/07/2014[/TD]
[/TR]
[TR]
[TD]000000LZ[/TD]
[TD]640351[/TD]
[TD]15/07/2014[/TD]
[/TR]
</tbody>[/TABLE]

Can any one help?

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG04Sep35
[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]
[COLOR="Navy"]Dim[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & 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]
        n = n + 1
        Cells(n, "E") = Dn.Value
        Cells(n, "F") = Dn.Offset(, 2).Value
        .Add Dn.Value, Array(n, 6)
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(Dn.Value)
            Q(1) = Q(1) + 1
            Cells(Q(0), Q(1)).Value = Dn.Offset(, 2).Value
        .Item(Dn.Value) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Summerso1]

Hi Mick, can this exclude the copying the ones that don't have a matching code like from the list above 000000I5 this code has no matching code therefore it should not be copied across. Thank you Mick!!!

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG04Sep33
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] k
[COLOR="Navy"]Dim[/COLOR] c           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] G           [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Ac          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & 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]
       .Add Dn.Value, Dn
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]


[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]If[/COLOR] .Item(k).Count > 1 [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        Cells(c, "E") = k
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] G [COLOR="Navy"]In[/COLOR] .Item(k)
            Ac = Ac + 1
            Cells(c, "E").Offset(, Ac) = DateValue(G.Offset(, 2))
        [COLOR="Navy"]Next[/COLOR] G
    [COLOR="Navy"]End[/COLOR] If
Ac = 0
[COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Summerso1]

Cheers Mick!!

 

[MickG]

You're welcome