Générer des initiales

**Liightning** · 10/02/2017, 11h40

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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,

**Daniel.C** · 10/02/2017, 11h52

Bonjour,

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

Cordialement.

Daniel

**mercatog** · 10/02/2017, 11h54

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é

**Liightning** · 10/02/2017, 14h24

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Invité · 10/02/2017, 15h00

Bonjour,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**Liightning** · 10/02/2017, 15h17

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

Cordialement

Invité · 10/02/2017, 15h20

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**Daniel.C** · 10/02/2017, 15h27

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 ?

**Liightning** · 10/02/2017, 15h38

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

**mercatog** · 10/02/2017, 15h39

A adapter

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Invité · 10/02/2017, 15h44

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

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

**Liightning** · 15/02/2017, 08h44

Bonjour à tous,

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Générer des initiales [XL-2013]

Macros et VBA Excel

Discussions similaires

Partager

Partager