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

000000HA	665587	13/08/2014
000000HB	529853	26/02/2014
000000HB	659642	07/08/2014
000000HB	668763	18/08/2014
000000I5	554083	31/03/2014
000000IU	656913	04/08/2014
000000KL	500644	22/01/2014
000000LN	560331	07/04/2014
000000LN	652808	30/07/2014
000000LZ	640351	15/07/2014

<colgroup><col><col><col></colgroup><tbody>
</tbody>

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