Fusionner les cellules de plusieurs lignes ayant le même index

Option Explicit
Private Sub cedz()
Dim fl As Worksheet, source As Range, texte As String, destination As Range, index As String
Set fl = ThisWorkbook.Sheets("cedz")
Set source = fl.[A1]
Set destination = fl.[C1]
index = ""
Do While source <> ""
    If source <> index Then
        If index <> "" Then
            destination = index
            destination.Offset(0, 1) = texte
            Set destination = destination.Offset(1, 0)
        End If
        index = source
        texte = source.Offset(0, 1)
    Else
        texte = texte + vbCrLf + CStr(source.Offset(0, 1))
    End If
    index = source
    Set source = source.Offset(1, 0)
Loop
If index <> "" Then
    destination = index
    destination.Offset(0, 1) = texte
End If
End Sub