XL 2016 Incrémenter des doublons sur la même ligne

Sub Incrémentation()
  
    Dim Plage As Range
    Dim Cel As Range
    Dim Dico As Object
    Dim ListeCle As Variant
    Dim Cle As Variant
    Dim I As Integer
  
    'défini la plage des champs pour la ligne 1
    With ActiveSheet
        Set Plage = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
    End With
    'crée le dictionnaire
    Set Dico = CreateObject("Scripting.Dictionary")
    'parcour les cellules et ajoute au dico si le champ n'existe pas
    'dans le cas contraire, l'incrémente
    For Each Cel In Plage
        If Dico.exists(Cel.Value) = False Then
            Dico.Add Cel.Value, 0
        Else
            'incrément la valeur de la clé
            Dico.Item(Cel.Value) = Dico.Item(Cel.Value) + 1
            'et crée la nouvelle clé avec l'incrémentation
            Dico.Add Cel.Value & Dico.Item(Cel.Value), 0
        End If
    Next Cel
    'récupère les clés
    ListeCle = Dico.Keys
    'colle les nouveaux champs à la place des anciens
    For I = 0 To Dico.Count - 1
        Plage(I + 1).Offset(0, 0) = ListeCle(I)
    Next I
    Set Dico = Nothing

End Sub