Hi again,

Am Sat, 31 Aug 2013 11:11:18 +0200 schrieb Claus Busch:

to do it in place try:

Sub Test()

with the code in last answer you get an error if a number exists only
one time.
Better try:

Sub Test()
Dim rngC As Range
Dim c As Range
Dim LRow As Long

LRow = Cells(Rows.Count, 1).End(xlUp).Row
For Each rngC In Range("A2:A" & LRow)
If WorksheetFunction.CountIf(Range(Cells(rngC.Row, 1), _
Cells(LRow, 1)), rngC) 1 Then
Do
With Range(Cells(rngC.Row + 1, 1), Cells(LRow, 1))
Set c = .Find(rngC, Cells(LRow, 1), xlValues).Offset(, 1)
If Not c Is Nothing Then
rngC.Offset(, 1) = rngC.Offset(, 1) & ", " & c
Rows(c.Row).Delete
LRow = LRow - 1
End If
End With
Loop While WorksheetFunction.CountIf( _
Range(Cells(rngC.Row, 1), Cells(LRow, 1)), rngC) 1
End If
Next
End Sub


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2