Incrémenter des doublons

Sub IncrementerDoublons()
'Permet d'incrémenter des doublons en ajoutant un chiffre (1,2,3...) au bout
'Grand Chaman Excel -  2011-09-24

    Dim rg As Range, rg2 As Range, rg3 As Range, c As Range
    Dim i As Integer
    Dim login As String, newlogin As String
    Dim bExist As Boolean
    
    Application.ScreenUpdating = False

    Set rg = Range("C2:C" & Range("C65000").End(xlUp).Row)  'plage contenant les login (avec doublons)
    
    For Each c In rg
        Set rg2 = Range("C2:C" & c.Offset(-1, 0).Row).Offset(0, 1)  'plage contenant les login corrigés (1 colonne à côté)
        login = c.Text
        newlogin = login
        i = 1
        Do
        Set rg3 = rg2.Find(what:=newlogin, LookIn:=xlValues, lookat:=xlWhole) 'on cherche si newlogin existe déjà
        bExist = True
        If Not rg3 Is Nothing Then  'il existe, alors on ajoute 1,2,3,... au bout
            newlogin = login & i
            bExist = True
            i = i + 1
        Else
            bExist = False
        End If
        Loop Until Not bExist
    c.Offset(0, 1) = newlogin
    Next c
    
    Application.ScreenUpdating = True
End Sub

Sub test()
'ligne et colonne de debut d'ecriture
ligne = 1
colonne = 2
'mise sous forme de tableau de la liste
Tablo = Range("A1:A" & Range("A65536").End(xlUp).Row) ' a adapter pour la liste d'origine
'creation d'un dictionnaire contenant les noms et le nombre par nom
Set d = CreateObject("Scripting.dictionary")
For n = LBound(Tablo) To UBound(Tablo)
 x = Tablo(n, 1)
 d(x) = d(x) + 1
Next n
'ecriture du resultat
a = d.keys
b = d.items
For n = LBound(a) To UBound(a)
 For m = 1 To b(n)
  If b(n) > 1 Then
   Cells(ligne, colonne) = a(n) & m
  Else
   Cells(ligne, colonne) = a(n)
  End If
  ligne = ligne + 1
 Next m
Next n
End Sub

=A2&SI(NB.SI($A$1:$A$200;A2)>1;NB.SI($A$1:$A2;A2);"")

Sub Logins()
    
    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 logins en colonne A à partir de A2
    With Worksheets("Feuil1")
     
        Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).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
            
            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 logins dans la colonne B
    For I = 0 To Dico.Count - 1
    
        Plage(I + 1).Offset(0, 1) = ListeCle(I)
        
    Next I
    
    Set Dico = Nothing

End Sub

Function LOGIN(nom$, prenom$, plage)
Dim i&
LOGIN = LCase(Left(nom, 3)) & LCase(Left(prenom, 3))
If plage.Count = 1 Then Exit Function
plage = Application.Transpose(plage) 'matrice => plus rapide
For i = UBound(plage) To 2 Step -1
  If Left(plage(i), 6) = LOGIN Then _
    LOGIN = LOGIN & Val(Mid(plage(i), 7, 9 ^ 9)) + 1: Exit Function
Next
End Function

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim l As Long, dl As Long, n As Long, P As Range
  Dim T
  l = Target.Row: dl = Cells(Rows.Count, 1).End(xlUp).Row
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  If Range("A" & l) = "" Or Range("B" & l) = "" Then
    'réactualisation de toutes les lignes en cas de suppression d'une donnée
    For n = 2 To dl
    Range("C" & n & ":D" & n) = ""
    Next
  End If
  '3 & 3
  Set P = Range("A" & l & ":B" & l)
  If Intersect(Target, P) Is Nothing Then Exit Sub
  T = Range("A2" & ":C" & dl)
  For n = 1 To dl - 1
    T(n, 3) = Left(T(n, 1), 3) & Left(T(n, 2), 3)
  Next
  'réécriture
  For l = 2 To dl
  Cells(l, "D") = T(l - 1, 3)
  n = Application.CountIf(Range("D2:D" & l), Cells(l, "D"))
  If Cells(l, "D") <> "" Then Cells(l, "C") = Cells(l, "D") & IIf(n = 1, "", n - 1)
  Next
  Application.EnableEvents = True
End Sub

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
           
        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)
            
            '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.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