Option Explicit

Sub abc()
    Dim r, lr, m, z1, z2, z3, t
    Dim sl: Set sl = CreateObject("Scripting.Dictionary")
    With ActiveSheet
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        m = .Cells(1, 1).Resize(lr, 4).Value
        For r = 3 To UBound(m)
            z3 = m(r, 3)
            If Len(z3) > 0 Then
                z1 = m(r, 1)
                z2 = m(r, 2)
                t = z1 & "|" & z2
                If sl.exists(t) Then
                    sl(t) = sl(t) & Chr(10) & z3
                Else
                    sl(t) = z3
                End If
            End If
        Next r

    
        For r = 3 To UBound(m)
            z1 = m(r, 1)
            z2 = m(r, 2)
            t = z1 & "|" & z2
            If sl.exists(t) Then
                .Cells(r, 4) = sl(t)
                sl.Remove (t)
            End If
        Next r
    End With
End Sub