Incrémenter des doublons

Sub test()
tablo = Range("A4:A" & Range("A65536").End(xlUp).Row)
For n = LBound(tablo) To UBound(tablo)
 tablo(n, 1) = LCase(tablo(n, 1))
 On Error Resume Next
 For m = 1 To 6
   y = Mid(tablo(n, 1), m, 1)
   x = Asc(y)
   If x < 97 Or x > 122 Then
     tablo(n, 1) = Replace(tablo(n, 1), y, "")
   End If
 Next m
 On Error GoTo 0
Next n
Range("B4").Resize(UBound(tablo)) = tablo
Set d = CreateObject("Scripting.dictionary")
derlin = Range("B65536").End(xlUp).Row
For Each cel In Range("B4:B" & derlin)
   x = Application.WorksheetFunction.CountIf(Range("B4:B" & derlin), cel.Value)
   If x > 1 Then
   d(cel.Value) = d(cel.Value) & cel.Row & ";"
   End If
Next
A = d.keys
B = d.items
coul = 3
For n = LBound(A) To UBound(A)
  x = Split(Left(B(n), Len(B(n)) - 1), ";")
  num = 1
  For m = LBound(x) To UBound(x)
    Cells(x(m), 2) = A(n) & num
    Cells(x(m), 2).Interior.ColorIndex = coul
    num = num + 1
  Next m
  coul = coul + 1
Next n
End Sub

Sub Change()
  Dim l As Long, dl As Long, n As Long, P As Range
  Dim T
  dl = Cells(Rows.Count, 1).End(xlUp).Row
  Application.ScreenUpdating = False
  Range("B3" & ":C" & dl).Clear
  T = Range("A4" & ":B" & dl)
  'corrections des textes
  For n = 1 To dl - 3
    T(n, 2) = Replace(T(n, 1), " ", "")
    T(n, 2) = Replace(T(n, 2), "ç", "c")
    T(n, 2) = Replace(T(n, 2), "-", "")
    T(n, 2) = Replace(T(n, 2), """", "")
    T(n, 2) = Sans_accents(T(n, 2))
    T(n, 2) = LCase(T(n, 2))
  Next
  'réécriture avec numérotation et couleurs
  For l = 4 To dl
    Cells(l, "C") = T(l - 3, 2)
    n = Application.CountIf(Range("C2:C" & l), Cells(l, "C"))
    If Cells(l, "C") <> "" Then Cells(l, "B") = Cells(l, "C") & IIf(n = 1, "", n - 1)
    If n > 1 Then Cells(l, "B").Interior.ColorIndex = 3 + n
  Next
   Columns(3).Delete
End Sub

'colorie la cellule à droite (avec la valeur du 2éme élément du tableau retourné par Split donc la valeur de J)
Cel.Offset(0, 1).Interior.Color = Split(Dico.Item(Cel.Value), ";")(1)

'colorie la cellule (avec la valeur du 2éme élément du tableau retourné par Split donc la valeur de J)
Cel.Offset.Interior.Color = Split(Dico.Item(Cel.Value), ";")(1)

Sub IncrementerDoublons()
   
    Dim Plage As Range
    Dim Cel As Range
    Dim Dico As Object
    Dim ListeCle As Variant
    Dim Cle As Variant
    Dim I As Integer
    Dim J As Long
    
    'défini la plage des logins en colonne A à partir de A2
    With Worksheets("Feuil1")
     
        Set Plage = .Range(.Cells(2, 7), .Cells(.Rows.Count, 7).End(xlUp))
   
    End With
   
    'crée le dictionnaire
    Set Dico = CreateObject("Scripting.Dictionary")
    
    'parcour les cellules et ajoute au dico si le nom n'existe pas
    'dans le cas contraire, l'incrémente
    For Each Cel In Plage
               
        If Dico.exists(Cel.Value) = False Then
            
            J = J + 1000
            
            Dico.Add Cel.Value, 0 & ";" & J & ";" & Cel.Address(0, 0)
           
        Else
           
            'incrément la valeur de la clé (1er élément du tableau retourné par Split)
            Dico.Item(Cel.Value) = CInt(Split(Dico.Item(Cel.Value), ";")(0)) + 1 & ";" _
                                   & Split(Dico.Item(Cel.Value), ";")(1) & ";" & _
                                   Split(Dico.Item(Cel.Value), ";")(2)
            
            'et crée la nouvelle clé avec l'incrémentation
            Dico.Add Cel.Value & Split(Dico.Item(Cel.Value), ";")(0), 0
            
            'colorie la cellule (avec la valeur du 2éme élément du tableau retourné par Split donc la valeur de J)
            Cel.Offset.Interior.Color = Split(Dico.Item(Cel.Value), ";")(1)
            
            'colorie la cellule d'origine (3éme élément du tableau retourné par Split) avec la même couleur que les doublons
            Range(Split(Dico.Item(Cel.Value), ";")(2)).Interior.Color = Split(Dico.Item(Cel.Value), ";")(1)
        
        End If
    
    Next Cel
       
    'récupère les clés
    ListeCle = Dico.Keys
   
    'colle les nouveaux logins dans la colonne à droite
    For I = 0 To Dico.Count - 1
   
        Plage(I + 1).Offset(0, 1) = ListeCle(I)
       
    Next I
   
    Set Dico = Nothing

End Sub