Macro fusion de cellules

Option Explicit

Sub test()
Dim a, i As Long, j As Byte, n As Long
    a = Sheets(1).Range("a2").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                n = n + 1
                For j = 1 To UBound(a, 2)
                    a(n, j) = a(i, j)
                Next
                .Item(a(i, 1)) = n
            Else
                a(.Item(a(i, 1)), 6) = a(.Item(a(i, 1)), 6) & _
                                       " " & a(i, 6)
            End If
        Next
    End With
    'restitution en Feuil2
    With Sheets(2).Range("a1")
        .CurrentRegion.Clear
        .Resize(n, UBound(a, 2)).Value = a
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Columns.AutoFit
            .Rows.RowHeight = 19
        End With
        .Parent.Activate
    End With
End Sub

Sub test()
Dim a, i As Long, j As Byte, n As Long, txt As String
    Application.ScreenUpdating = False
    'La feuille à traiter en 1ère position dans le classeur
    'Les données à partir de A1
    a = Sheets(1).Range("a1").CurrentRegion.Value
    'Avec en-têtes
    n = 1
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            'Détermine la clé sur les 2 premiéres colonnes
            txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))
            If Not .exists(txt) Then
                n = n + 1
                For j = 1 To UBound(a, 2)
                    a(n, j) = a(i, j)
                Next
                .Item(txt) = n
            Else
                a(.Item(txt), 6) = a(.Item(txt), 6) & _
                                   " " & a(i, 6)
            End If
        Next
    End With
    'Création d'une nouvelle feuille et restitution
    With Sheets.Add.Cells(1)
        .CurrentRegion.Clear
        .Resize(n, UBound(a, 2)).Value = a
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Rows.RowHeight = 19
            With .Rows(1)
                .Interior.ColorIndex = 42
                .BorderAround Weight:=xlThin
            End With
            .Columns.AutoFit
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub