Excel concatenate and carriage return by columns

Can you upload an example workbook. With before and after results wanted?

misread the question - post removed.

Should do the trick

     Public Sub CombineEntries()
     '# declare
          Dim lngRowNumber As Long
          Dim lngInnerLoop As Long
          Dim strKeyValue As String
          Dim lngKeyStart As Long
          Dim strCombineValue
     '# initialise
          lngKeyStart = 0
     '# loop for all rows
          With ActiveSheet
               For lngRowNumber = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
                    If .Cells(lngRowNumber, "A").Value <> strKeyValue Then
                         If lngKeyStart > 0 Then
                              For lngInnerLoop = lngKeyStart To lngRowNumber - 1
                                   .Cells(lngInnerLoop, "D").Value = strCombineValue
                              Next lngInnerLoop
                         End If
                         lngKeyStart = lngRowNumber
                         strKeyValue = .Cells(lngRowNumber, "A").Value
                         strCombineValue = .Cells(lngRowNumber, "C").Value
                    Else
                         strCombineValue = strCombineValue & vbLf & .Cells(lngRowNumber, "C").Value
                    End If
               Next lngRowNumber
               If lngKeyStart > 0 Then
                    For lngInnerLoop = lngKeyStart To lngRowNumber - 1
                         .Cells(lngInnerLoop, "D").Value = strCombineValue
                    Next lngInnerLoop
               End If
          End With
     End Sub

This should do it

Option Explicit
Sub abc()
 Dim a, i As Long
 
 a = Range("a2", Cells(Rows.Count, "a").End(xlUp).Offset(, 2)).Value

 Application.ScreenUpdating = False
 With CreateObject("scripting.dictionary")
    .comparemode = 1
    For i = 1 To UBound(a)
        If Not .exists(a(i, 1)) Then
            .Item(a(i, 1)) = a(i, 3)
        Else
            .Item(a(i, 1)) = .Item(a(i, 1)) & vbCrLf & a(i, 3)
        End If
    Next
    For i = 1 To UBound(a)
        Cells(i, "d").Offset(1) = .Item(a(i, 1))
    Next
 End With
 Application.ScreenUpdating = True
End Sub

This should do it

Option Explicit

Sub abc()
 Dim a, i As Long
 
 a = Range("a2", Cells(Rows.Count, "a").End(xlUp).Offset(, 3)).Value

 Application.ScreenUpdating = False
 With CreateObject("scripting.dictionary")
    .comparemode = 1
    For i = 1 To UBound(a)
        If Not .exists(a(i, 1) & a(i, 2)) Then
            .Item(a(i, 1) & a(i, 2)) = a(i, 4)
        Else
            .Item(a(i, 1) & a(i, 2)) = .Item(a(i, 1) & a(i, 2)) & vbCrLf & a(i, 4)
        End If
    Next
    For i = 1 To UBound(a)
        Cells(i, "e").Offset(1) = .Item(a(i, 1) & a(i, 2))
    Next
 End With
 Application.ScreenUpdating = True
End Sub