Incrémenter des doublons

[cybergui77]

Bonjour,
Je suis sur excel 2003.
Je suis en train de créer des login pour des personnes afin qu'elles puissent se connecter à un domaine. Pour créer ce login je colle les 3 premières lettres du nom et du prénom (ex: "DUPONT Catie" donne "dupcat").
Le problème, c'est que sur plusieurs milliers de login, j'ai des doublons, parfois 3 ou 4 occurrences identiques.
Je voudrais dans un premier temps que chacun des doublons trouvés soient automatiquement incrémenté d'un chiffre 1,2,3, etc. (Ex: "DUPONT Catie" donne "dupcat1" et "DUPRES Catherine" donne "dupcat2", etc.)
Je voudrais dans un deuxième temps que cette macro s'applique sur une colonne et que les modifications soient écrit dans une autre colonne.
Piouf, j'ai eu beau chercher je n'ai rien trouvé sur la toile....
Donc un grand merci d'avance !

 

[pierrejean]

Re : Incrémenter des doublons

Re

Ma version (applicable directement a la colonne A ,resltat en colonne B traitant l'exclusion des signes spéciaux)

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

Edit: je regarde la solution de Theze

 

[Si...]

Re : Incrémenter des doublons

Salut

Pour le fun

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

La colonne A contenant les 3+3 originaux, après avoir supprimé les colonnes qui servent à corriger le texte (la macro s'en occupant), la colonne suivante (ici B) contiendra les corrections avec les doublons numérotés. La macro utilise la colonne suivant la suivante (ici C).
Ici, les couleurs sont attribuées par nombre de doublons !

 

[Theze]

Re : Incrémenter des doublons

Bonsoir,

Hé bien, si après ça il s'en sort (cybergui77) 🙂 avec tous ces codes !

Hervé.

 

[cybergui77]

Re : Incrémenter des doublons

Merci Hervé,
j'ai bien mis mes logins à partir de A2 mais cela colorie G2 en rouge et affiche le chiffre 1 en H2 et c'est tout...
J'ai du louper un truc !!

 

[Theze]

Re : Incrémenter des doublons

Re,

Oups, dans mon second post, j'ai pas modifié le commentaire :

'défini la plage des logins en colonne A à partir de A2

En fait, comme dans ton classeur exemple les doublons sont en colonne G, c'est par rapport à cette dernière que j'ai modifié mon code, donc les logins en doublon seront colorés en colonne G et les logins incrémentés seront en colonne H, adapte ici si tu veux en colonne H la coloration :

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

au lieu de :

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

Hervé.

 

[cybergui77]

Re : Incrémenter des doublons

Bonjour "Si...",
lorsque j’exécute votre macro cela fait "erreur de compilation", mes login étant dans la colonne A à partir de A2.

Bonjour Hervé,
je viens de tester votre macro, j'ai opté pour la deuxième solution à savoir colorier la colonne H. Cependant, cela ne colorie pas le login doublon non incrémenté. Du coup, sans vous vexer, la solution de PierreJean correspond mieux à mes attentes (merci PierreJean !). Mais je suis sûr qu'en un coup de cuiller à pot vous allez corriger cela lol. Vous êtes vraiment des passionnés, c'est génial et pour ne rien gâcher, vous êtes aussi très sympa ! Merci !

 

[Theze]

Re : Incrémenter des doublons

Bonjour,

Voici la proc modifiée pour colorer la cellule d'origine de la même couleur que les doublons :

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

Hervé.

 

[cybergui77]

Re : Incrémenter des doublons

Merci, cela fonctionne nickel !
Merci à tous et bonne continuation !

 

[Si...]

Re : Incrémenter des doublons

Salut

donc avec un fichier exemple et 2 styles de coloration (ne sachant pas comment tu veux les exploiter).
Remarque : en commençant par mettre les textes en minuscules (LCase) les listes de la fonction s'en trouve raccourcies et ici, tu as toujours les colonnes de formules en moins.

 

[cybergui77]

Re : Incrémenter des doublons

Salut Si...
Génial comment cela simplifie mon tableau excel, c'est impressionnant !
Cependant, les colonnes C et D ne me seront pas utiles. J'aurais souhaité mettre les couleurs dans B et avoir une couleur identique non pas par nombre de doublons identiques (si j'ai bien compris le résultat en C) mais une couleur par "famille de doublons".
Merci encore !

 

[Si...]

Re : Incrémenter des doublons

Salut

pour la couleur,c'est ce que fait la seconde macro, non ?
Elle est encore simplifiée (et commentée) dans le fichier joint.

 

[cybergui77]

Re : Incrémenter des doublons

Merci Si...
c'est exactement ce qu'il me fallait !
Cela donne envie de savoir écrire les macro soit même !
C'est tellement puissant.
Encore un GRAND merci.
++