On Saturday, August 31, 2013 10:18:56 AM UTC+1, Claus Busch wrote:
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

Thanks Howard, it works perfect but I might use Claus solution as it it works in place and saves a few lines of code for me.

Great answers guys many thanks