Identify row duplicates and merge unique data

Hi Melisa,

Welcome to the Forum!

Attach a sample workbook. Make sure there is just enough data to demonstrate your need. Include a BEFORE sheet and an AFTER sheet in the workbook if needed to show the process you're trying to complete or automate. Make sure your desired results are shown, mock them up manually if necessary.

Remember to desensitize the data.

Click on GO ADVANCED and use the paperclip icon to open the upload window.

View Pic

I am unable to upload the test file. I receive the error below.

"This assest is not currently being used by any content that you have access to."

Could it be blocked by my workplace? I'm sorry...new to this.

Edited: Okay it looks like the file did make it

Hi Meliisa,

Try this:

Sub Melisa(): Dim LN As String, i As Long, j As Long
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row - 1
            LN = Range("A" & i)
For j = i + 1 To Range("A" & Rows.Count).End(xlUp).Row
            If Range("A" & j) = LN Then
            If Trim(Range("D" & i)) <> Trim(Range("D" & j)) Then _
            Range("D" & i) = Range("D" & i) & ", " & Range("D" & j)
            If Trim(Range("E" & i)) <> Trim(Range("E" & j)) Then _
            Range("E" & i) = Range("E" & i) & ", " & Range("E" & j)
            If Trim(Range("F" & i)) <> Trim(Range("F" & j)) Then _
            Range("F" & i) = Range("F" & i) & ", " & Range("F" & j)
            Range("A" & j).EntireRow.Delete Shift:=xlUp: j = j - 1
            End If
Next j: Next i: Columns.AutoFit: End Sub

Directions for running the routine(s) just supplied

Copy the code to the clipboard

Open your Workbook

Press ALT + F11 to open the Visual Basic Editor.

Select "Module" from the Insert menu

Type "Option Explicit" then paste the code under it

With the cursor between Sub and End Sub press F5 (F8 to Single Step)

OR

Press ALT + Q to close the code window.

Press ALT + F8 then double click on the macro name

Perhaps next code can help
Note:
for Loan Number = 765 it is not the same Step 5 (space at the end)

Option Explicit

Sub Melisa()
Dim WkTb
Dim ObjDic   As Object
Dim I  As Long, II As Long
Dim J  As Integer
Dim Temp
    Set ObjDic = CreateObject("Scripting.Dictionary")
    WkTb = Sheets("Current Data").Range("A1").CurrentRegion
    For I = 2 To UBound(WkTb, 1)
        If (ObjDic.exists(WkTb(I, 1))) Then
            Temp = ObjDic(WkTb(I, 1))
            For II = 2 To 5
                If (Temp(II) <> WkTb(I, II + 2)) Then WkTb(I, II + 2) = Temp(II) & "," & WkTb(I, II + 2)
            Next II
        End If
        ObjDic(WkTb(I, 1)) = Array(WkTb(I, 2), WkTb(I, 3), WkTb(I, 4), _
                                       WkTb(I, 5), WkTb(I, 6), WkTb(I, 7), WkTb(I, 8))
    Next I
    With Sheets("Wanted outcome")
        .Cells.ClearContents
        .Cells(1, 1).Resize(1, 8) = Array("Loan Number", "Due Date", "Name", "Data 1", "Data 2", "Data 3", "Data 4", "Value")
        .Cells(2, 1).Resize(ObjDic.Count, 1) = Application.Transpose(ObjDic.keys)
        .Cells(2, 2).Resize(ObjDic.Count, 7) = Application.Transpose(Application.Transpose(ObjDic.items))
    End With
End Sub

OK Melisa, just keep us informed