Sub Объединить_дубликаты()

    Dim shSrc As Worksheet, shRes As Worksheet
    Dim arr(), lr As Long, i As Long
    
    Application.ScreenUpdating = False
    
    Set shSrc = ActiveSheet
    shSrc.Copy After:=shSrc
    Set shRes = shSrc.Next
    
    If shRes.AutoFilterMode = True Then
        shRes.ShowAllData
    End If
    shRes.Rows.Hidden = False
    
    shRes.Columns("A").Copy shRes.Columns("D")
    shRes.Columns("A").Delete
    
    shRes.Sort.SortFields.Clear
    shRes.Sort.SortFields.Add Key:=shRes.Columns("A"), SortOn:=xlSortOnValues, Order:=xlAscending
    shRes.Sort.SortFields.Add Key:=shRes.Columns("B"), SortOn:=xlSortOnValues, Order:=xlAscending
    shRes.Sort.SortFields.Add Key:=shRes.Columns("C"), SortOn:=xlSortOnValues, Order:=xlAscending
    With shRes.Sort
        .SetRange shRes.Columns("A:C")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
    
    lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
    arr() = shRes.Range("A1:C" & lr).Value
    For i = UBound(arr) To 3 Step -1
        If arr(i, 1) = arr(i - 1, 1) And arr(i, 2) = arr(i - 1, 2) Then
            arr(i - 1, 3) = arr(i - 1, 3) & Chr(10) & arr(i, 3)
            arr(i, 1) = Empty
        End If
    Next i
    
    shRes.Range("A1:C" & lr).Value = arr()
    
    On Error Resume Next
    shRes.Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    
    shRes.Columns("A:C").HorizontalAlignment = xlCenter
    shRes.Columns("A:C").VerticalAlignment = xlCenter
    
    Application.ScreenUpdating = True

End Sub

Sub Объединить_дубликаты()

    Dim shSrc As Worksheet, shRes As Worksheet
    Dim arr(), lr As Long, i As Long
    
    Application.ScreenUpdating = False
    
    Set shSrc = ActiveSheet
    Set shRes = Worksheets.Add(After:=shSrc)
    shSrc.Columns("F:G").Copy shRes.Columns("A:B")
    shSrc.Columns("L:M").Copy shRes.Columns("C:D")
    shSrc.Columns("J").Copy shRes.Columns("E")
    shSrc.Columns("B").Copy shRes.Columns("F")
    MergeAddress shRes
    shRes.Columns("D").Delete
    
    shRes.Sort.SortFields.Add Key:=shRes.Columns("A"), SortOn:=xlSortOnValues, Order:=xlAscending
    shRes.Sort.SortFields.Add Key:=shRes.Columns("B"), SortOn:=xlSortOnValues, Order:=xlAscending
    shRes.Sort.SortFields.Add Key:=shRes.Columns("E"), SortOn:=xlSortOnValues, Order:=xlAscending
    With shRes.Sort
        .SetRange shRes.Columns("A:E")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
    
    lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
    arr() = shRes.Range("A1:E" & lr).Value
    For i = UBound(arr) To 3 Step -1
        If arr(i, 1) = arr(i - 1, 1) And arr(i, 2) = arr(i - 1, 2) Then
            arr(i - 1, 3) = arr(i, 3)
            arr(i - 1, 4) = arr(i, 4)
            arr(i - 1, 5) = arr(i - 1, 5) & Chr(10) & arr(i, 5)
            arr(i, 1) = Empty
        End If
    Next i
    
    shRes.Range("A1:E" & lr).Value = arr()
    
    On Error Resume Next
    shRes.Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    
    shRes.Columns("A:E").HorizontalAlignment = xlCenter
    shRes.Columns("A:E").VerticalAlignment = xlCenter
    
    Application.ScreenUpdating = True

End Sub

Private Sub MergeAddress(shRes As Worksheet)

    Dim arr1(), arr2(), lr As Long, i As Long
    
    lr = shRes.Columns("C:D").Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
    arr1() = shRes.Range("C2:D" & lr).Value
    ReDim arr2(1 To UBound(arr1), 1 To 1)
    
    For i = 1 To UBound(arr1)
        arr2(i, 1) = arr1(i, 1) & ", " & arr1(i, 2)
    Next i
    shRes.Range("C2").Resize(UBound(arr2)).Value = arr2()

End Sub