Simplification d'une partie de macro

Version imprimable

Bonjour à tous.

En raison de la situation actuelle, et pour faire passer le temps, je me suis lancé un défi.
Faire un Scrabble sur Excel.
Prétentieux pour un amateur aguerri, mais j'aime bien me casser la tête :aie:

Cependant, après trois semaines à essayer de trouver par moi-même, je doit avouer que je bloque sur un bout de code que je voudrait mettre en place, et aimerait donc un petit coup de main.

Tout d'abord, voici ce que je voudrait faire :
- Je souhaiterais établir, à partir d'un texte qui a déjà fait l'objet d'un traitement de tri alphabétique, pouvoir lister toutes les combinaisons de mots possibles.
Pour cela, voici les données à prendre en compte :
- Le mot doit faire entre 2 et 15 lettres.
- Toutes les lettres de l'alphabet sont pris en compte (de A à Z, en majuscule bien entendu).
- Parmi les 102 jetons que l'ont peux piocher, 2 sont des jokers, pouvant prendre comme valeur n'importe quelle lettre de l'alphabet (majuscule).
-

Ainsi, avec ces données, voici un exemple qu'Excel doit me ressortir :
- Mot de base 7 lettres : "?ABCDEF" avec en gras la valeur du joker.
- Liste de mot de 2 lettres : AA, BA, etc... BA, BB, BC, etc...
- Liste de mot de 3 lettres : AAB, BAB, etc... AAC, BAC, CAC, etc...
- Liste de mot de 4 lettres : etc...
- jusqu'à 7 lettres

Jusque là j'ai pu m'en sortir.

Mais il est possible d'avoir deux joker tel que "??ABCDE".

C'est à ce niveau que je n'arrive plus à faire gérer les valeurs des jokers pour me ressortir la liste voulue.

De plus, j'aimerais savoir si il y a un moyen de simplifier le morceau de code ci-joint ?

Si quelqu'un pourrait me mettre sur la voie, je vous en serait reconnaissant.

Je ne peux mettre mon fichier actuel en pj, trop volumineux...

Dans l'attente d'un retour ;)

Bien cordialement.

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
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
 
Sub Lister_les_possibilites_du_chevalet()
 
Dim L1 As Long, L2 As Long, L3 As Long, L4 As Long, L5 As Long, L6 As Long, L7 As Long
Dim Lettre_1 As String, Lettre_2 As String, Lettre_3 As String, Lettre_4 As String, Lettre_5 As String, Lettre_6 As String, Lettre_7 As String
Dim mot_mem As String
Dim i As Long
Dim col_pla_rec_mot_fin As Long
Declarer_les_donnees
 
'Stop
Worksheets(feu_pla).Select
 
Application.ScreenUpdating = False
a = 2
nb = 0
 
lig_pla_rec_mot_deb = Worksheets(feu_pla).Range("Ligne_de_recherche_zero").Row + 1
col_pla_rec_mot_deb = Worksheets(feu_pla).Range("Ligne_de_recherche_zero").Column
 
lig_pla_rec_mot_fin = Worksheets(feu_pla).Cells(1048576, col_pla_rec_mot_deb + 1).End(xlUp)(2).Row
col_pla_rec_mot_fin = col_pla_rec_mot_deb + 4
 
Worksheets(feu_pla).Range(Cells(lig_pla_rec_mot_deb, col_pla_rec_mot_deb), Cells(lig_pla_rec_mot_fin, col_pla_rec_mot_fin)).Value = ""
 
nb_lettre = Len(Worksheets(feu_pla).Range("Chevalet_test_trié").Value)
 
If nb_lettre < 2 Then
    Exit Sub
Else
 
Do While a <= nb_lettre
    For L1 = 1 To nb_lettre
    Lettre_1 = Mid(Worksheets(feu_pla).Range("Chevalet_test_trié").Value, L1, 1)
        For L2 = L1 + 1 To nb_lettre
        Lettre_2 = Mid(Worksheets(feu_pla).Range("Chevalet_test_trié").Value, L2, 1)
            If a >= 3 Then
            For L3 = L2 + 1 To nb_lettre
            Lettre_3 = Mid(Worksheets(feu_pla).Range("Chevalet_test_trié").Value, L3, 1)
                If a >= 4 Then
                For L4 = L3 + 1 To nb_lettre
                Lettre_4 = Mid(Worksheets(feu_pla).Range("Chevalet_test_trié").Value, L4, 1)
                    If a >= 5 Then
                    For L5 = L4 + 1 To nb_lettre
                    Lettre_5 = Mid(Worksheets(feu_pla).Range("Chevalet_test_trié").Value, L5, 1)
                        If a >= 6 Then
                        For L6 = L5 + 1 To nb_lettre
                        Lettre_6 = Mid(Worksheets(feu_pla).Range("Chevalet_test_trié").Value, L6, 1)
                            If a >= 7 Then
                            For L7 = L6 + 1 To nb_lettre
                            Lettre_7 = Mid(Worksheets(feu_pla).Range("Chevalet_test_trié").Value, L7, 1)
'Stop
                    If Lettre_1 = "?" And a <= nb_lettre Then GoTo Symbole1 Else GoTo Normal
 
Reprendre6:
 
 
                            Next
                            Else
 
                            If Lettre_1 = "?" And a <= nb_lettre Then GoTo Symbole1 Else GoTo Normal
Reprendre5:
 
 
                            End If
                        Next
                        Else
 
                    If Lettre_1 = "?" And a <= nb_lettre Then GoTo Symbole1 Else GoTo Normal
Reprendre4:
 
 
                        End If
                    Next
                    Else
 
                    If Lettre_1 = "?" And a <= nb_lettre Then GoTo Symbole1 Else GoTo Normal
Reprendre3:
 
 
                    End If
                Next
                Else
 
                If Lettre_1 = "?" And a <= nb_lettre Then GoTo Symbole1 Else GoTo Normal
Reprendre2:
 
                End If
            Next
            Else
 
                If Lettre_1 = "?" And a <= nb_lettre Then GoTo Symbole1 Else GoTo Normal
Reprendre1:
 
            'Mot_valide
            End If
        Next
 
    Next
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
a = a + 1
'Stop
Loop
End If
''''''''''''''''''''''''''''
 
'lig_pla_rec_mot_deb = Worksheets(feu_pla).Range("Ligne_de_recherche_zero").Row + 1
'lig_pla_rec_mot_fin = Worksheets(feu_pla).Cells(1048576, col_pla_rec_mot_deb).End(xlUp)(2).Row
 
 
'Do While lig_pla_rec_mot_deb < lig_pla_rec_mot_fin
'    mot_ecr = Worksheets(feu_pla).Cells(lig_pla_rec_mot_deb, col_pla_rec_mot_deb + 1).Value
'    i = lig_pla_rec_mot_deb + 1
'    Do While i < lig_pla_rec_mot_fin
'        If Worksheets(feu_pla).Cells(i, col_pla_rec_mot_deb + 1).Value = mot_ecr Then
'            Worksheets(feu_pla).Cells(lig_pla_rec_mot_deb, col_pla_rec_mot_deb + 1).Select
'            Worksheets(feu_pla).Cells(i, col_pla_rec_mot_deb + 1).Select
'            Worksheets(feu_pla).Cells(i, col_pla_rec_mot_deb + 1).Value = ""
'        Else: End If
'    i = i + 1
'    Loop
'lig_pla_rec_mot_deb = lig_pla_rec_mot_deb + 1
'Loop
 
lig_pla_rec_mot_deb = Worksheets(feu_pla).Range("Ligne_de_recherche_zero").Row + 1
lig_pla_rec_mot_fin = Worksheets(feu_pla).Cells(1048576, col_pla_rec_mot_deb).End(xlUp)(2).Row
 
'Worksheets(feu_pla).Range(Cells(lig_pla_rec_mot_deb, col_pla_rec_mot_deb), Cells(lig_pla_rec_mot_fin, col_pla_rec_mot_fin)).Select
 
    ActiveWorkbook.Worksheets("Plateau").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Plateau").Sort.SortFields.Add Key:=Range(Cells(lig_pla_rec_mot_deb, col_pla_rec_mot_deb + 4), Cells(lig_pla_rec_mot_fin, col_pla_rec_mot_deb + 4)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Plateau").Sort.SortFields.Add Key:=Range(Cells(lig_pla_rec_mot_deb, col_pla_rec_mot_deb + 1), Cells(lig_pla_rec_mot_fin, col_pla_rec_mot_deb + 1)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
 
    With ActiveWorkbook.Worksheets("Plateau").Sort
        .SetRange Range(Cells(lig_pla_rec_mot_deb, col_pla_rec_mot_deb + 1), Cells(lig_pla_rec_mot_fin, col_pla_rec_mot_fin))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
   End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = True
 
                Worksheets(feu_pla).Range(Cells(lig_pla_rec_mot_deb, col_pla_rec_mot_deb + 1), Cells(lig_pla_rec_mot_deb, col_pla_rec_mot_deb + 3)).Select
 
MsgBox "Terminé"
 
Exit Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
Symbole1:
For i = 1 To 26
    Lettre_1 = Chr(64 + i)
 
    mot_ecr = Tri_alphabétique_du_mot(Lettre_1 & Lettre_2 & Lettre_3 & Lettre_4 & Lettre_5 & Lettre_6 & Lettre_7)
    Mot_valide
    'MsgBox mot_ecr
Next
i = 1
Lettre_1 = Mid(Worksheets(feu_pla).Range("Chevalet_test_trié").Value, L1, 1)
Lettre_2 = Mid(Worksheets(feu_pla).Range("Chevalet_test_trié").Value, L2, 1)
 
'Stop
GoTo Retour
 
Normal:
    mot_ecr = Lettre_1 & Lettre_2 & Lettre_3 & Lettre_4 & Lettre_5 & Lettre_6 & Lettre_7
    Mot_valide
GoTo Retour
 
Retour:
If Lettre_3 = "" Then
    GoTo Reprendre1
ElseIf Lettre_4 = "" Then
    GoTo Reprendre2
ElseIf Lettre_5 = "" Then
    GoTo Reprendre3
ElseIf Lettre_6 = "" Then
    GoTo Reprendre4
ElseIf Lettre_7 = "" Then
    GoTo Reprendre5
ElseIf Lettre_7 <> "" Then
    GoTo Reprendre6
Else
 
End If
 
 
End Sub

08/05/2020, 15h23
Philippe Tulliez

Bonjour,
Sauf erreur de ma part, la liste de données doit être constituée de mots sous forme d'anagramme trié par ordre croissant et ainsi une fonction basée sur la méthode Find pourrait renvoyer la liste des mots contenant les mots sortis, qui serait également un anagramme trié par ordre croissant.
Cette fonction devrait faire moins de 10 lignes de code

Il est certainement possible également de le faire en utilisant les expressions régulières.
A lire éventuellement Les Expressions Rationnelles appliquées en VBA Access
10/05/2020, 13h14
Icolf

Bonjour,

Je vous remercie de votre réponse.

Dans un premier temps, je vais me rapprocher de l'anagramme et find pour essayer à nouveau :mrgreen:

Après avoir obtenu ce que je souhaite, je regarderais les expressions régulières :)

En tout cas merci.

PS : Je n'oublierais pas de clore le sujet lorsque j'aurais trouvé ;)
10/05/2020, 18h44
laurent_ott

Bonjour.
J'avoue ne pas être un spécialiste du sujet, ni même être sûr d'avoir compris la question.
Donc pas de réponse ici mais juste des idées :

1) Il faudrait partir d'un dictionnaire des mots admis au jeu (verbes + conjugaisons + mots + adverbes + accords), soit environ entre 500.000 et 1Mo de mots. Ça reste dans les possibilités d'Excel.

2) Pour savoir quel mot admis un joueur peut avoir avec son tirage, je ferais comme ça:
- Je prends la liste des mots admis (en partant des mots les plus longs vers les plus courts).
- Pour chaque mot : je mémorise le tirage du joueur dans une mémoire temporaire, par exemple TPS.
Pour chaque lettre du mot admis à analyser je regarde si la lettre est dans TPS (fonction Instr qui donne > 0) si non alors,
je regarde s'il y a un jocker dans TPS (qui remplace cette lettre, toujours avec Instr),
si non alors je passe au mot suivant, (après avoir reconstitué TPS),
si oui alors je remplace la lettre de TPS par "*" (fonction Mid) pour ne pas qu'elle soit considérée comme bonne réponse une deuxième fois.
Si toutes les lettres du mot sont dans TPS alors le mot est une possibilité et je quitte la recherche.

3) La possibilité trouvée doit maintenant être placée sur le jeu. C'est une autre histoire qui n'était pas dans l'énoncé du problème.
Pour cela je propose d'ajouter "virtuellement" au tirage du joueur (en amont au traitement (2) que je viens de décrire) une ou plusieurs lettres du plateau où un mot pourrait être placé.
Et donc de relancer le traitement sur toutes les possibilités de placement possibles.

Ajout : calculer les anagrammes de 15 lettres c'est bien trop long (1 307 674 368 000‬ combinaisons). C'est la raison pour laquelle je pars des mots admis et non des anagrammes.

Bonne continuation.
24/05/2020, 16h03
Icolf

1 pièce(s) jointe(s)

Bonjour,

Veuillez m'excuser de la réponse tardive, j'ai voulu essayer de chercher par moi-même, et j'avoue que je n'arrive plus à réfléchir tellement j'ai essayé de chose (recherche sur Google).
Pour vous dire, j'y suis depuis 8h ce matin....

Effectivement, vous avez raison.
La gestion de ce que je souhaite réaliser s'effectue en passant par les anagrammes en tri alphabétique.
Depuis mon dernier poste, j'ai pu récupérer à droite à gauche les informations nécessaires pour la programmation de mon fichier.
J'ai pu également récupérer et commencer à modifié à ma convenance, et dans mes limites, un fichier que quelqu'un avait commencé et publié (je ne me souvient plus du nom, je m'en excuse).
Cette personne passe par un document dawg comme base de dictionnaire, et j'avoue que c'est génial.
Je gagne un temps énorme par rapport à ce que j'avais pu faire pour les recherches et validation des mots.

Cependant, je souhaite approfondir ce fichier, et /ou compléter mes connaissances, et je bloque...

Je vous joins ce que j'ai essayé de commencer.

Je souhaiterais qu'Excel puisse me sortir, à partir d'un mot d'une longueur variable (de 2 à 7 lettres), la liste des possibilités de tirage.

Pour exemple :
Avec les lettres de bases suivantes : "ABCDEFG"
- Liste de mot de 2 lettres : "AB, AC, AD, AE, AF, AG, BA, BC, BD, etc...
- Liste de mot de 3 lettres : ABC, ABD, etc... ACD, ACE, ACF, etc...
- Liste de mot de 4 lettres : ABCD, ACBE, etc...
- jusqu'à 7 lettres

J'arrive à avoir la liste des mots de 2 lettres, et par miracle j'avais réussi à avoir la liste des mots de 3 lettres.
Cependant, après modification pour passer à la taille supérieur, plus moyen d'y accéder...

Je suis conscient que le nombre de possibilités est énorme. Je les avais calculés pour m'amuser.
Mais ces données seront temporaires le temps d'une étude sur ces mots.

En vous remerciant par avance du coup de pouce que vous pourrez m'apporter :)
Bien cordialement
24/05/2020, 16h42
laurent_ott

Comme déjà dit, je ne suis pas un spécialiste du sujet, mais à chaud il me semble inutile de programmer les anagrammes sur deux lettres, puis sur trois, puis sur quatre, etc. Pourquoi ne pas faire la liste directement sur sept lettres, puis parcourir la liste sur le deux premières, puis les trois premières, etc. Les doublons seront sans conséquence et la programmation plus simple.
C'est juste une idée.
Cordialement.

Bonjour à tous !!!

Ayant eu très peu de temps depuis le dé-confinement (travail oblige), je reviens sur le site pour clore le sujet, comme promis.

Effectivement, je viens de réussir de trouver ce que je cherchais.

Ci-dessous le code en question.

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
 
Option Explicit
 
Dim Dico As Object
 
Sub AppelCombi()
Dim TexteCombi As String, Tablo
Dim J As Long
 
  TexteCombi = Application.InputBox(prompt:="Entrer le texte ici")
  TexteCombi = Trier(TexteCombi)
  Range("A:A").ClearContents
  Set Dico = CreateObject("Scripting.Dictionary")
  Call Combi("", TexteCombi)
  Tablo = Dico.keys
  For J = 1 To Dico.Count
    Range("A" & J).Value = Tablo(J - 1)
  Next J
  'Application.Run Range("motsCroisés.xls!nbValA")
End Sub
 
Sub Combi(Prefixe As String, Texte As String)
Dim i As Long
  If Len(Texte) <= 1 Then
    Dico(Prefixe & Texte) = Prefixe & Texte
  Else
    For i = 1 To Len(Texte)
      Call Combi(Prefixe & Mid(Texte, i, 1), Left(Texte, i - 1) & Right(Texte, Len(Texte) - i))
    Next i
  End If
End Sub
Function Trier(ByVal Lettres As String) As String
    Dim Position As Byte, Place As Byte, Nombre_Lettres As Byte
    Dim Lettre As String, Resultat As String
 
    Nombre_Lettres = Len(Lettres)
    For Position = 1 To Nombre_Lettres
        Lettre = Mid(Lettres, Position, 1)
        If Resultat = "" Then
            Resultat = Lettre
        ElseIf Len(Resultat) = 1 Then
            Resultat = IIf(Lettre > Resultat, Resultat & Lettre, Lettre & Resultat)
        Else
            Place = 1
            While Lettre > Mid(Resultat, Place, 1) And Place < Len(Resultat)
                Place = Place + 1
            Wend
            Resultat = Left(Resultat, Place - 1) & Lettre & Right(Resultat, Len(Resultat) - Place + 1)
        End If
    Next Position
    Trier = Resultat
End Function

En vous remerciant pour l'aide que vous m'avez apporté :)

Bien cordialement tout le monde.