Merging duplicate row IDs

[eric1987]

I was using a vlookup to get data from an ID, but I have realised that I have duplicate ID's in the database.
I am wanting to merge duplicate row ID's within a database, but keeping all data contained for them.
I am expecting there to be up to a max of 5 duplicates, so repeating the Fruit/Animal/Colour columns up to 5 times to the right.
I also want to be able to keep the highest number in Column B that is attributed to that ID.
ID's are not in numerical order in the database, and contain both numbers and letters.

Please see the following example:

Currently						Output
ID	Number	Fruit	Animal	Colour		ID	Number	Fruit	Animal	Colour	Fruit	Animal	Colour	Fruit	Animal	Colour
1	1	Apple				1	10	Apple						Banana	Bear	Red
2	1					2	10				Cherry	Ant	Blue	Apple	Cat
3	1	Cherry				3	2	Cherry			Banana
4	10	Banana	Ant	Red		4	10	Banana	Ant	Red				Cherry	Cat
5	10	Apple	Ant	Yellow		5	10	Apple	Ant	Yellow				Banana
1	2
2	10	Cherry	Ant	Blue
3	2	Banana
4	3
5	1
1	10	Banana	Bear	Red
2	2	Apple	Cat
3	1
4	3	Cherry	Cat
5	4	Banana

<tbody>
</tbody>

How would I go about doing this in Excel?
Thanks in advance.

 

[MickG]

With Data on sheet "Current" and the results on sheet "Output", try this:-

[COLOR="Navy"]Sub[/COLOR] MG19Aug07
[COLOR="Navy"]Dim[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]With[/COLOR] Sheets("Current")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("A2", Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
[COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
    Dic.Add Dn.Value, Dn.Offset(, 1).Value
[COLOR="Navy"]Else[/COLOR]
[COLOR="Navy"]If[/COLOR] Dn.Offset(, 1).Value > Dic(Dn.Value) [COLOR="Navy"]Then[/COLOR] Dic(Dn.Value) = Dn.Offset(, 1).Value
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Output")
    .Range("A2").Resize(Dic.Count, 2) = Application.Transpose(Array(Dic.Keys, Dic.items))
    .Range("A1:B1").Value = Array("ID", "Number")
[COLOR="Navy"]For[/COLOR] n = 1 To Rng.Count [COLOR="Navy"]Step[/COLOR] 5
    Ac = Ac + 3
    .Cells(1, Ac).Resize(, 3).Value = Sheets("Current").Range("C1:E1").Value
    .Cells(2, Ac).Resize(5, 3).Value = Sheets("Current").Cells(n + 1, 3).Resize(5, 3).Value
[COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]With[/COLOR] .Range("A1").Resize(6, Ac + 2)
         .Borders.Weight = 2
         .Columns.AutoFit
    [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick