Générer des initiales

Version imprimable

Bonjour à tous,

Je me permets de demander un petit coup de pouce car je pense vraiment ne pas être loin de ce que je cherche à faire mais rien n'y fait... J'ai un soucis avec l'objet "dictionnaire"

Code:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 Sub INITIALES() 'initialise le compteur Début tmp = GetTickCount64 Application.ScreenUpdating = False Dim initiale As String Dim d As Range Dim n As Variant Dim Tableau() Set dictionnaire = CreateObject("Scripting.Dictionary") i = Range("B65000").End(xlUp).Row Set plage = Range("a6:a" & i) Range("b6").Select n = 1 ' Range("B6").Select For Each d In plage ' Do Until (IsEmpty(ActiveCell)) ' pos = ActiveCell.Adress If dictionnaire.exists(d.Value) Then Do If ActiveCell.Offset(0, 3).Text Like "*Visage*" Or ActiveCell.Offset(0, 3).Text Like "*Bébé*" Or _ ActiveCell.Offset(0, 3).Text Like "*Rincés*" Then initiale = Mid((ActiveCell.Offset(0, 1).Value), 1, 1) & Mid((ActiveCell.Offset(0, 0).Value), n, 1) Else initiale = Mid((ActiveCell.Offset(0, 1).Value), 1, 1) & Mid((ActiveCell.Offset(0, 0).Value), n, 1) & _ Right(ActiveCell.Offset(0, 0).Value, 1) End If n = n + 1 Loop Until Not dictionnaire.exists(d.Value) ActiveCell.Offset(0, -1) = initiale dictionnaire.Add d.Value, d.Value n = 1 Else If Not dictionnaire.exists(d.Value) Then If ActiveCell.Offset(0, 3).Text Like "*Visage*" Or ActiveCell.Offset(0, 3).Text Like "*Bébé*" Or _ ActiveCell.Offset(0, 3).Text Like "*Rincés*" Then initiale = Mid((ActiveCell.Offset(0, 1).Value), 1, 1) & Mid((ActiveCell.Offset(0, 0).Value), 1, 1) Else initiale = Mid((ActiveCell.Offset(0, 1).Value), 1, 1) & Mid((ActiveCell.Offset(0, 0).Value), 1, 1) & _ Right(ActiveCell.Offset(0, 0).Value, 1) End If ActiveCell.Offset(0, -1) = initiale dictionnaire.Add d.Value, d.Value End If End If ActiveCell.Offset(1, 0).Select Next d
Mon problème se situe au niveau de ce pavé là. J'ai essayé pas mal de chose déjà mais rien trouvé à l'heure actuelle.
Ce que je souhaite, c'est que si ma d.value est déjà présente dans mon dictionnaire, je veux qu'il applique la boucle Do jusqu'à ce qu'il trouve une valeur de d.value non existante dans le dictionnaire (à l'aide de la variable n) qu'il l'inscrive dans la cellule et l'enregistre dans le dictionnaire

n = variable qui à chaque boucle va en fait permettre d'utiliser la lettre suivante du contenu de la cellule
Cette variante n est réinitialisée à chaque sortie de boucle et reprend ça valeur initiale à savoir 1

Si je ne suis pas assez explicite n'hésitez pas à me demander d'autres infos. Cependant je ne pourrai pas vous communiquer le fichier en pièce jointe étant donné la sensibilité des informations. Je tâcherai de vous répondre au mieux.

Merci d'avance pour votre aide,

Cordialement,

10/02/2017, 11h52
Daniel.C

Bonjour,

Il serait peut-être plus simple que tu dises ce que tu cherches à faire, plutôt que de commenter ton code.

Cordialement.

Daniel
10/02/2017, 11h54
mercatog

Bonjour
Entre le titre et le contenu, loin d'être clair
On commence par expliquer le but et après ce que ton code est censé réaliser et enfin où exactement la difficulté

Bonjour à vous deux.

Veuillez m'excuser je pensais avoir suffisamment décrit mon problème. Anyway je reprends

En gros j'ai un tableau qui ressemble à ça

Initiales NOM Prénom Truc1 Truc2 Truc3

? DURAND Arnaud Bébé

Je cherche donc à créer une macro qui me permette d'attribuer des initiales en respectant quelques règles :

Si dans la colonne Truc3 il y a présence du mot "Bébé" on attribue que 2 initiales

Première initiale = Première lettre du Prénom
Deuxième initiale = Première lettre du Nom

Sinon on attribue 3 initiales

Première initiale = Première lettre du Prénom
Deuxième initiale = Première lettre du Nom
Troisième initiale = Dernière lettre du Nom

Ensuite, pour l'attribution des initiales je souhaite qu'il n'y ait aucun doublon au fur et à mesure du remplissage de la colonne Initiale. Si à un moment la macro est susceptible de générer un doublon il faut qu'elle puisse s'en rendre compte et donc essayer de créer des initiales non attribuées.

Pour cela j'utilise le code suivant:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 Sub INITIALES() 'initialise le compteur Début tmp = GetTickCount64 Application.ScreenUpdating = False Dim initiale As String Dim d As Range Dim n As Variant Dim Tableau() Set dictionnaire = CreateObject("Scripting.Dictionary") i = Range("B65000").End(xlUp).Row Set plage = Range("a6:a" & i) Range("b6").Select n = 1 For Each d In plage If dictionnaire.exists(d.Value) Then Do If ActiveCell.Offset(0, 3).Text Like "*Visage*" Or ActiveCell.Offset(0, 3).Text Like "*Bébé*" Or _ ActiveCell.Offset(0, 3).Text Like "*Rincés*" Then initiale = Mid((ActiveCell.Offset(0, 1).Value), 1, 1) & Mid((ActiveCell.Offset(0, 0).Value), n, 1) Else initiale = Mid((ActiveCell.Offset(0, 1).Value), 1, 1) & Mid((ActiveCell.Offset(0, 0).Value), n, 1) & _ Right(ActiveCell.Offset(0, 0).Value, 1) End If n = n + 1 Loop Until Not dictionnaire.exists(d.Value) ActiveCell.Offset(0, -1) = initiale dictionnaire.Add d.Value, d.Value n = 1 Else If Not dictionnaire.exists(d.Value) Then If ActiveCell.Offset(0, 3).Text Like "*Visage*" Or ActiveCell.Offset(0, 3).Text Like "*Bébé*" Or _ ActiveCell.Offset(0, 3).Text Like "*Rincés*" Then initiale = Mid((ActiveCell.Offset(0, 1).Value), 1, 1) & Mid((ActiveCell.Offset(0, 0).Value), 1, 1) Else initiale = Mid((ActiveCell.Offset(0, 1).Value), 1, 1) & Mid((ActiveCell.Offset(0, 0).Value), 1, 1) & _ Right(ActiveCell.Offset(0, 0).Value, 1) End If ActiveCell.Offset(0, -1) = initiale dictionnaire.Add d.Value, d.Value End If End If ActiveCell.Offset(1, 0).Select Next d Call ColoriageDoublons 'Initialise le compteur Fin tmpFin = GetTickCount64 Application.ScreenUpdating = True MsgBox ("durée ; " & (tmpFin - tmp) / 1000 & " secondes.") '1,625 sans application.screenUpdating / 0,188 avec End Sub
Mon problème est que lorsque les INITIALES sont déjà présentes dans la colonne, la macro n'effectue pas toujours (une fois sur dix je dirais) la boucle où je lui demande de décaler la lettre utilisée de n+1 pour créer les initiales.

Pour être plus parlant voici un exemple de doublon que je veux éviter
DUPOND Arnaud ---> la macro va donc attribuer les lettre AD en tant qu'initiales
DUBOIS Arthur ----> la macro devrait attribuer les lettres AD également mais je souhaite donc que la macro boucle afin d'utiliser la prochaine lettre du nom qui n'entre pas en conflit avec une autre INITIALE déjà attribuée. Dans le cas présent il faudrait AU
DUPRA Alice ----> Idem. La macro devrait attribuée AD mais déjà utilisée, donc faut qu'elle boucle, utilise AU mais elle aussi déjà attribuée, donc passer à la lettre suivante et donc attribué AP

Et c'est donc sur ce système là que je bloque... Ma macro fonctionne jusqu'au premier doublon et après message d'erreur stipulant que l'entrée dans le dictionnaire est déjà présente

Je vous remercie par avance de votre aide et patience,

Cordialement

Bonjour,

Code:

1
2
3
4
5
6
7
8
Sub test()
Truc3 = "Bébé"
nom = "DURAND"
pnom = "Arnaud"
Debug.Print Array(Left(pnom, 1) & Left(nom, 1) & Right(nom, 1), Left(pnom, 1) & Left(nom, 1))(Abs(Truc3 = "Bébé"))
Truc3 = "Cheval"
Debug.Print Array(Left(pnom, 1) & Left(nom, 1) & Right(nom, 1), Left(pnom, 1) & Left(nom, 1))(Abs(Truc3 = "Bébé"))
End Sub

10/02/2017, 15h17
Liightning

1 pièce(s) jointe(s)

Merci pour la réponse Dysortographie mais je maîtrise pas suffisamment la fonction Debug.Print afin de l'appliquer à mon fichier actuel. J'utilise la fenêtre d'exécution essentiellement et surtout le F8 en contrôlant les informations les unes après les autres.

Je joins un fichier incluant tout le script de ma macro ainsi qu'un morceau de tableau (test)

Comme mentionné dans mon précédent message ça bloque au niveau de la gestion des Initiales déjà attribuées,
En espérant que cela est suffisant pour vous permettre d'y voir plus clair

Je vous remercie de prendre du temps pour mon problème ;) :roll:

Cordialement

Code:

1
2
3
4
5
6
7
8
9
10
11
Sub test()
Truc3 = "Bébé"
nom = "DURAND"
pnom = "Arnaud"
d = CBool(InStr(Truc3, "Visage") + InStr(Truc3, "Bébé") + InStr(Truc3, "Rincés"))
MsgBox Array(Left(pnom, 1) & Left(nom, 1) & Right(nom, 1), Left(pnom, 1) & Left(nom, 1))(Abs(d))
Truc3 = "Rincés": d = d = CBool(InStr(Truc3, "Visage") + InStr(Truc3, "Bébé") + InStr(Truc3, "Rincés"))
MsgBox Array(Left(pnom, 1) & Left(nom, 1) & Right(nom, 1), Left(pnom, 1) & Left(nom, 1))(Abs(d))
Truc3 = "Cheval": d = d = CBool(InStr(Truc3, "Visage") + InStr(Truc3, "Bébé") + InStr(Truc3, "Rincés"))
MsgBox Array(Left(pnom, 1) & Left(nom, 1) & Right(nom, 1), Left(pnom, 1) & Left(nom, 1))(Abs(d))
End Sub

Code:

d = CBool(InStr(Trim("" & ActiveCell.Offset(0, 3).Text), "Visage") + InStr(Trim("" & ActiveCell.Offset(0, 3).Text), "Bébé") + InStr(Trim("" & ActiveCell.Offset(0, 3).Text), "Rincés"))

10/02/2017, 15h27
Daniel.C

Citation:

il faut qu'elle puisse s'en rendre compte et donc essayer de créer des initiales non attribuées.

Quelle règle pour la création d'initiales dans ces cas ?
10/02/2017, 15h38
Liightning

Citation:

Envoyé par Daniel.C

Quelle règle pour la création d'initiales dans ces cas ?

Première initiale = Première lettre du Prénom
Deuxième initiale = variable jusqu'à ce que la macro trouve une combinaison non utilisée (sur le nom)
(Si) Troisième initiale = Dernière lettre du nom

@dysortographe
Je suppose que tu me donnes ces codes afin que je simplifie le bloc de traitement avec tout mon bazar de ActiveCell.Offset ^^'
Je prends bonne note de ce que tu m'a donné. J'ai pas pensé à utilisé le InStr en effet. Cependant je comprends pas trop où tu veux en venir avec un code pareil, je ne suis pas sûr que cela m'aide beaucoup dans ce que je cherche à réaliser.

Cordialement,
Merci à vous

A adapter

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub INITIALE()
Dim Dico As Object
Dim Tmp As String
Dim i As Long
Dim Tb
 
Tb = Feuil1.Range("A6:E9")
Set Dico = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Tb)
    Do
        j = j + 1
        Tmp = Left(Tb(i, 3), 1) & Mid(Tb(i, 2), j, 1) & IIf(LCase(Tb(i, 5)) = "bébé", Right(Tb(i, 2), 1), "")
    Loop Until Not Dico.exists(Tmp)
    If j <= Len(Tb(i, 2)) Then
        Dico.Add Tmp, ""
        Tb(i, 1) = Tmp
    End If
    j = 0
Next i
Feuil1.Range("A6:E9") = Tb
End Sub

10/02/2017, 15h44
Invité

Citation:

Envoyé par Liightning

@dysortographe
Je suppose que tu me donnes ces codes afin que je simplifie le bloc de traitement avec tout mon bazar de ActiveCell.Offset ^^'
Je prends bonne note de ce que tu m'a donné. J'ai pas pensé à utilisé le InStr en effet. Cependant je comprends pas trop où tu veux en venir avec un code pareil, je ne suis pas sûr que cela m'aide beaucoup dans ce que je cherche à réaliser.

Cordialement,
Merci à vous

Un test est toujours booléenne!

Code:

if "a"="a"=true then msgbox abs(true)

abs converti true en 1;

un tableau (array) commence à 0 et ça tombe bien c'est la valeur du false!

Code:

msgbox array("False","True")(false)

Code:

msgbox array("False","True")(abs(true))

en résumée je converti tout le if par un arry()(false/true)

Bonjour à tous,

Merci de vous être investi sur mon projet. Je vous informe que j'ai trouvé la réponse.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
 
Sub VISA2()
 
    Dim initiale As String
    Dim d As Range
    Dim n As Variant
    Dim Tableau()
 
    'initialise le compteur Début
    tmp = GetTickCount64
    Application.ScreenUpdating = False
 
    Set dictionnaire = CreateObject("Scripting.Dictionary")
    '************************************************************************************
    ' Peut être supprimé car non utiliser.
    'i indique la fin de la plage. Il pouvait être utilisé dans ta procédure pour stopper
    'la boucle à un endroit stratégique de ta procédure.
    ' Peut être supprimé car non utiliser
    i = Range("B65000").End(xlUp).Row
    Set plage = Range("a6:a" & i)
    '************************************************************************************
    Range("b6").Select
    n = 1
 
 
 
Line1:
    Do
        If ActiveCell.Offset(0, 3).Text Like "*Visage*" Or ActiveCell.Offset(0, 3).Text Like "*Bébé*" Or _
           ActiveCell.Offset(0, 3).Text Like "*Rincés*" Then
            initiale = Mid((ActiveCell.Offset(0, 1).Value), 1, 1) & Mid((ActiveCell.Offset(0, 0).Value), n, 1)
 
        Else
            initiale = Mid((ActiveCell.Offset(0, 1).Value), 1, 1) & Mid((ActiveCell.Offset(0, 0).Value), n, 1) & _
                       Right(ActiveCell.Offset(0, 0).Value, 1)
 
            If dictionnaire.exists(initiale) Then
                GoTo Line2
            Else
                ActiveCell.Offset(0, -1) = initiale
                dictionnaire.Add initiale, ""
            End If
            ActiveCell.Offset(1, 0).Select
 
            '************************************************************************************
            'rajouté par PHE pour stopper la boucle lorsque le dernier visa est en place
            'sinon il traite les lignes vides et ça mouline à l'infini
            If ActiveCell.Value = "" Then
                'Initialise le compteur Fin
                tmpFin = GetTickCount64 'rajouté par PHE
                Application.ScreenUpdating = True 'rajouté par PHE
                MsgBox ("durée ; " & (tmpFin - tmp) / 1000 & " secondes.") 'rajouté par PHE
                Exit Sub 'rajouté par PHE
            End If 'rajouté par PHE
            '************************************************************************************
            n = 1
            GoTo Line1
        End If
Line2:
        n = n + 1
    Loop Until Not dictionnaire.exists(initiale)
    ActiveCell.Offset(0, -1) = initiale
    dictionnaire.Add initiale, ""
    n = 1
    ActiveCell.Offset(1, 0).Select
    GoTo Line1
Call ColoriageDoublons
End Sub

Encore merci et bonne journée à vous