Merge multiple rows with unique ID but keep notes

[lizardbreath]

Hi Team,

Looking to see if this is possible with excel VBA. I have a spreadsheet that has 4 columns

1) LeadId
2) ActionDateTime
3) ActionTaken
4) ActionNote
5) Finalized Note

On this spreadsheet I need the "LeadId" to be de-duped, but the different log entries of the ActionDateTime,ActionTaken,andActionNote merged together and displayed in the Finalized note column in chronological order.

As an example, let's say you had this data below. When completing the merge there would be 1 row for Lead Id 7742, but the actiondatetime, actiontaken, and action note would all be merged and put into the field "Finalized Note".

[TABLE="width: 1411"]
<colgroup><col><col><col><col><col></colgroup><tbody>[TR]
[TD]Id[/TD]
[TD]ActionDateTime[/TD]
[TD]ActionTaken[/TD]
[TD]ActionNote[/TD]
[TD]Finalized Note[/TD]
[/TR]
[TR]
[TD="align: right"]7742[/TD]
[TD="align: right"]10/1/2018 8:00[/TD]
[TD]NoContact[/TD]
[TD]TYPE=Buying&AdditionalNotes=7/31 NA, no VM setup[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD="align: right"]7742[/TD]
[TD="align: right"]10/1/2018 9:00[/TD]
[TD]LeftMessage[/TD]
[TD]TYPE=Buy and Sell&AdditionalNotes=sell in OR and buy in WA-she won one of the raffle prizes 8/28 was at work said she will call me later, has not been preapproved yet[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD="align: right"]7742[/TD]
[TD="align: right"]10/1/2018 10:00[/TD]
[TD]SetAppointment[/TD]
[TD]TYPE=&AdditionalNotes=2/16 left vm and sent text 4/4 left vm and sent another text[/TD]
[TD] [/TD]
[/TR]
</tbody>[/TABLE]

 

[Puertorekinsam]

You will need to clean this up a little for your needs...

Sub Cleanup()



ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
    .SetRange Range("A:E")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
   
   
i = 1

Do Until Sheet2.Cells(i, 1) = ""
    If Sheet2.Cells(i + 1, 1) = Sheet2.Cells(i, 1) Then
        If Sheet2.Cells(i, 5) <> "" Then Sheet2.Cells(i, 5) = Sheet2.Cells(i, 5) & ";"
        Sheet2.Cells(i, 5) = Sheet2.Cells(i + 1, 2) & " " & Sheet2.Cells(i + 1, 3) & " " & Sheet2.Cells(i + 1, 4)
    
    Sheet2.Rows(i + 1).Delete
    Else
        i = i + 1
        Sheet2.Cells(i, 5) = Sheet2.Cells(i, 2) & " " & Sheet2.Cells(i, 3) & " " & Sheet2.Cells(i, 4)
        
        Sheet2.Range(Sheet2.Cells(i, 2), Sheet2.Cells(i, 4)).Clear
    End If

Loop
    
    
End Sub