husakt,
If you want the result without deleting original data then use
Sub test_KeepOriginal()
Dim e, x, a(), n As Long
With Cells(1).CurrentRegion.Offset(1)
For Each e In Filter(Evaluate("transpose(if(countif(offset(" & .Columns(1).Address & _
",,,row(1:" & .Rows.Count & "))," & .Columns(1).Address & ")=1," & .Columns(1).Address & _
",char(2)))"), Chr(2), 0)
x = Application.Index(.Value, Application.Match(Val(e), .Columns(1), 0), 0)
x(14) = Join(Filter(Evaluate("transpose(if(" & .Columns(1).Address & "=" & e & ",trim(" & _
.Columns(14).Address & "),char(2)))"), Chr(2), 0), ", ")
n = n + 1: ReDim Preserve a(1 To n): a(n) = x
Next
.Offset(.Rows.Count + 3).Resize(n).Value = Application.Index(a, 0, 0)
End With
End Sub
Otherwise
Sub test_DeleteRows()
Dim i As Long, x As Range, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
With Cells(1).CurrentRegion
For i = 2 To .Rows.Count
If Not dic.exists(.Cells(i, 1).Value) Then
dic(.Cells(i, 1).Value) = i
Else
.Cells(dic(.Cells(i, 1).Value), 8).Value = _
Trim$(.Cells(dic(.Cells(i, 1).Value), 8).Value) & _
", " & Trim$(.Cells(i, 8).Value)
If x Is Nothing Then
Set x = .Rows(i).EntireRow
Else
Set x = Union(x, .Rows(i).EntireRow)
End If
End If
Next
End With
If Not x Is Nothing Then x.Delete
End Sub
Doesn't need to sort the data before you run.
Bookmarks