Thread: Duplicate rows delete and moving cells

You definately do NOT want to be merging cells!' this should do what you want provided your data is laid out as in the example, change the sheet names to suit:

Sub find_and_concatenate()
'**  code supplied by Simon Lloyd **
'**  02/09/2010                   **
'**  http://www.thecodecage.com   **
Dim c As Range, FirstAddress As String
Dim MyCell As Range, Rng As Range
Dim i As Long, r As Long
r = 0
Set Rng = Sheets("Sheet1").Range("A1:A" & Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row)
For Each MyCell In Rng
If Application.WorksheetFunction.CountIf(Sheets("Sheet1").Range("E1:E" _
& Sheets("Sheet1").Range("E" & Rows.Count).End(xlUp).Row), MyCell.Value) >= 1 Then GoTo Nxt
If MyCell.Row = 1 Then GoTo N1
    With Rng
        Set c = .find(MyCell, LookIn:=xlValues)
        If Not c Is Nothing Then
        Sheets("Sheet1").Range("E" & Rows.Count).End(xlUp).Offset(r, 0) = c.Value
        Sheets("Sheet1").Range("F" & Rows.Count).End(xlUp).Offset(r, 0) = c.Offset(0, 1) & "#" & c.Offset(0, 2)
        
            FirstAddress = c.Address
            
            i = 1
            Do
                Set c = .FindNext(c)
                If c.Address <> FirstAddress Then
                Sheets("Sheet1").Range("F" & Rows.Count).End(xlUp).Offset(0, i) = c.Offset(0, 1) & "#" & c.Offset(0, 2)
                i = i + 1
                End If
            Loop While Not c Is Nothing And c.Address <> FirstAddress
            
        End If
    End With
Nxt:
r = 1
N1:
Next MyCell
End Sub