XL 2016 Le Mot Le Plus Long

[halecs93]

Bonjour à tous,


C’est encore du bricolage, mais le résultat est plutôt satisfaisant pour l’instant. J’aimerais l’améliorer afin de pouvoir jouer à deux joueurs, avec un comptage des points. Si l’un des joueurs est l’ordinateur, ce n’est pas un problème : on le considère simplement comme un joueur à part entière.


Le tout, idéalement, sans connexion en ligne.


Des idées ou des suggestions ?

Je poste le fichier ici, vu sa lourdeur : https://www.swisstransfer.com/d/73ade0ae-4513-426e-a0f8-837edeec0ff2

Merci beaucoup

 

[crocrocro]

bonjour,
j'avais regardé votre précédent post : Le Mot Le Plus Long pour lequel j'avais une suggestion d'optimisation que je fais ici :
En colonne A, la liste des mots en Minuscules accentuées
En colonne B, l'équivalent en Majuscules non accentuées
En colonne C, la longueur du mot.
La feuille est triée (une bonne fois pour toute) sur colonne C longueur de mot décroissant (niveau 1), colonne A par ordre alphabétique (niveau 2).
Lors de la recherche du mot le plus
Balayage de la feuille ligne à ligne en comparant la colonne B avec les Lettres (majuscules) tirées. Cela évite le Ucase à chaque ligne.
Si on ne souhaite donner 1 seul mot comme solution, on s'arrête au 1er mot trouvé (le dictionnaire étant trié par longueur de mot décroissant)
On affiche comme solution la valeur de la ligne en colonne A (Minuscules accentuées)
Si on ne souhaite donner tous les mots trouvés de même longueur que le 1er trouvé, on poursuit le balayage et on s'arrête à la 1ère ligne dont la longueur de mot est inférieure aux mots trouvés précédemment
On affiche comme solutions les valeurs des lignes en colonne A (Minuscules accentuées).
Pour adapter un peu la présentation comme le jeu télévisé
au lieu d'afficher la (ou les) solutions dans le userform,
Dire le mot (en minuscules) et l'épeler en utilisant la fonction SPEACH, en supprimant au fur et à mesure la lettre de la ligne 1 de la feuille pour la faire apparaitre à la bonne place en ligne 9.
Éventuellement, afficher également la liste des mots trouvés.

 

[halecs93]

bonjour,
j'avais regardé votre précédent post : Le Mot Le Plus Long pour lequel j'avais une suggestion d'optimisation que je fais ici :
En colonne A, la liste des mots en Minuscules accentuées
En colonne B, l'équivalent en Majuscules non accentuées
En colonne C, la longueur du mot.
La feuille est triée (une bonne fois pour toute) sur colonne C longueur de mot décroissant (niveau 1), colonne A par ordre alphabétique (niveau 2).
Lors de la recherche du mot le plus
Balayage de la feuille ligne à ligne en comparant la colonne B avec les Lettres (majuscules) tirées. Cela évite le Ucase à chaque ligne.
Si on ne souhaite donner 1 seul mot comme solution, on s'arrête au 1er mot trouvé (le dictionnaire étant trié par longueur de mot décroissant)
On affiche comme solution la valeur de la ligne en colonne A (Minuscules accentuées)
Si on ne souhaite donner tous les mots trouvés de même longueur que le 1er trouvé, on poursuit le balayage et on s'arrête à la 1ère ligne dont la longueur de mot est inférieure aux mots trouvés précédemment
On affiche comme solutions les valeurs des lignes en colonne A (Minuscules accentuées).
Pour adapter un peu la présentation comme le jeu télévisé
au lieu d'afficher la (ou les) solutions dans le userform,
Dire le mot (en minuscules) et l'épeler en utilisant la fonction SPEACH, en supprimant au fur et à mesure la lettre de la ligne 1 de la feuille pour la faire apparaitre à la bonne place en ligne 9.
Éventuellement, afficher également la liste des mots trouvés.

ha merci.... je vais regarder de pluis près "speach"

 

[crocrocro]

Je me suis trompé, c'est Application.Speech.Speak.
Voici le code qui est en partie une adaptation du vôtre et une copie d'écran de la feuille principale après affichage de la solution

Sub Solution()
    Dim Mot As String
    Dim Tirage As String
    Dim i As Long
    Dim Message As String

    NbLettresTirees = 0
    For i = 1 To NB_MAX_LETTRES_A_TIRER  '12
        If Sheets(f_PRINCIPAL).Cells(LIG_CARTE1, COL_CARTE1 + i - 1) = "" Then Exit For
        NbLettresTirees = NbLettresTirees + 1
    Next i
    
    Tirage = ""
    ' Récupérer les lettres tirées
    For i = 1 To NbLettresTirees
        Tirage = Tirage & LCase(Sheets(f_PRINCIPAL).Cells(LIG_CARTE1, COL_CARTE1 + i - 1).Value)
    Next i

    MeilleurMot = ""
    Erase TabTrouve
    NTrouve = 0
    For i = 1 To Sheets(f_DICO).Cells(Rows.Count, "A").End(xlUp).Row
        Mot = Sheets(f_DICO).Cells(i, 2).Value
        If Len(Mot) <= NbLettresTirees Then
            If MotPossible(Mot, Tirage) Then
                ' le dico est trié par longieur décroissante
                If Len(Mot) >= Len(MeilleurMot) Then
                    NTrouve = NTrouve + 1
                    ReDim Preserve TabTrouve(1 To NTrouve)
                    TabTrouve(NTrouve) = Sheets(f_DICO).Cells(i, 1).Value
                    If Len(Mot) > Len(MeilleurMot) Then
                        MeilleurMot = TabTrouve(NTrouve)
                    End If
                End If
            End If
        End If

        'End If
    Next i
    If MeilleurMot = "" Then
        AfficherRienTrouve
    Else
        AfficherMotTrouve
    End If
End Sub


Function MotPossible(Mot As String, Lettres As String) As Boolean
    Dim Temp As String
    Dim i As Long

    Temp = Lettres

    For i = 1 To Len(Mot)
        If InStr(Temp, Mid(Mot, i, 1)) = 0 Then
            MotPossible = False
            Exit Function
        Else
            Temp = Replace(Temp, Mid(Mot, i, 1), "", , 1)
        End If
    Next i

    MotPossible = True
End Function


Sub AfficherRienTrouve()
Dim Message As String

    Application.ScreenUpdating = True
    Message = "Aucun Mot trouvé"
    Application.Speech.Speak (Message)
    MsgBox Message, , "Liste des Mots trouvés"

End Sub
Sub AfficherMotTrouve()
Dim i As Integer
Dim j As Integer
Dim Fin1 As Boolean
Dim C As Range
Dim Message As String
Dim MotEpele As String

    Application.EnableEvents = False
    With Sheets(f_PRINCIPAL)
        Application.Speech.Speak Len(TabTrouve(1)) & " lettres"
        Application.Speech.Speak TabTrouve(1)
        'on supprime les accents et on convertit en majuscule
        MotEpele = TabTrouve(1)
        tAvec = Split(avecAccent)
        tSans = Split(SansAccent)
        For i = LBound(tAvec) To UBound(tAvec)
            MotEpele = Replace(MotEpele, tAvec(i), tSans(i), , , 1)
        Next i
        Application.ScreenUpdating = True
        For i = 1 To Len(TabTrouve(1))
            'suppression de la lettre dans la liste
            Fin1 = False
            For j = 1 To NB_MAX_LETTRES_A_TIRER
                With .Cells(LIG_CARTE1, COL_CARTE1 + j - 1)
                    If (.Font.TintAndShade = 0) And Not Fin1 Then
                        'If .Value = UCase(Mid(Cells(1, 1), i, 1)) Then
                        If .Value = UCase(Mid(MotEpele, i, 1)) Then
                            .Font.ColorIndex = .Interior.ColorIndex
                            .Font.ThemeColor = .Interior.ThemeColor
                            .Font.TintAndShade = .Interior.TintAndShade
                            Fin1 = True
                        End If
                    End If
                End With
            Next j
            .Cells(1, 3 + i) = UCase(Mid(MotEpele, i, 1))
            Application.Speech.Speak (.Cells(1, 3 + i))
        Next i
    End With
    Message = NTrouve & " Mot(s) en " & Len(TabTrouve(1)) & " lettre(s)"
    For i = 1 To NTrouve
        Message = Message & vbCrLf & "   - " & TabTrouve(i)
    Next i
    MsgBox Message, , "Liste des Mots trouvés"
        
    Application.EnableEvents = True

End Sub

 

[halecs93]

Je me suis trompé, c'est Application.Speech.Speak.
Voici le code qui est en partie une adaptation du vôtre et une copie d'écran de la feuille principale après affichage de la solution

Sub Solution()
    Dim Mot As String
    Dim Tirage As String
    Dim i As Long
    Dim Message As String

    NbLettresTirees = 0
    For i = 1 To NB_MAX_LETTRES_A_TIRER  '12
        If Sheets(f_PRINCIPAL).Cells(LIG_CARTE1, COL_CARTE1 + i - 1) = "" Then Exit For
        NbLettresTirees = NbLettresTirees + 1
    Next i
   
    Tirage = ""
    ' Récupérer les lettres tirées
    For i = 1 To NbLettresTirees
        Tirage = Tirage & LCase(Sheets(f_PRINCIPAL).Cells(LIG_CARTE1, COL_CARTE1 + i - 1).Value)
    Next i

    MeilleurMot = ""
    Erase TabTrouve
    NTrouve = 0
    For i = 1 To Sheets(f_DICO).Cells(Rows.Count, "A").End(xlUp).Row
        Mot = Sheets(f_DICO).Cells(i, 2).Value
        If Len(Mot) <= NbLettresTirees Then
            If MotPossible(Mot, Tirage) Then
                ' le dico est trié par longieur décroissante
                If Len(Mot) >= Len(MeilleurMot) Then
                    NTrouve = NTrouve + 1
                    ReDim Preserve TabTrouve(1 To NTrouve)
                    TabTrouve(NTrouve) = Sheets(f_DICO).Cells(i, 1).Value
                    If Len(Mot) > Len(MeilleurMot) Then
                        MeilleurMot = TabTrouve(NTrouve)
                    End If
                End If
            End If
        End If

        'End If
    Next i
    If MeilleurMot = "" Then
        AfficherRienTrouve
    Else
        AfficherMotTrouve
    End If
End Sub


Function MotPossible(Mot As String, Lettres As String) As Boolean
    Dim Temp As String
    Dim i As Long

    Temp = Lettres

    For i = 1 To Len(Mot)
        If InStr(Temp, Mid(Mot, i, 1)) = 0 Then
            MotPossible = False
            Exit Function
        Else
            Temp = Replace(Temp, Mid(Mot, i, 1), "", , 1)
        End If
    Next i

    MotPossible = True
End Function


Sub AfficherRienTrouve()
Dim Message As String

    Application.ScreenUpdating = True
    Message = "Aucun Mot trouvé"
    Application.Speech.Speak (Message)
    MsgBox Message, , "Liste des Mots trouvés"

End Sub
Sub AfficherMotTrouve()
Dim i As Integer
Dim j As Integer
Dim Fin1 As Boolean
Dim C As Range
Dim Message As String
Dim MotEpele As String

    Application.EnableEvents = False
    With Sheets(f_PRINCIPAL)
        Application.Speech.Speak Len(TabTrouve(1)) & " lettres"
        Application.Speech.Speak TabTrouve(1)
        'on supprime les accents et on convertit en majuscule
        MotEpele = TabTrouve(1)
        tAvec = Split(avecAccent)
        tSans = Split(SansAccent)
        For i = LBound(tAvec) To UBound(tAvec)
            MotEpele = Replace(MotEpele, tAvec(i), tSans(i), , , 1)
        Next i
        Application.ScreenUpdating = True
        For i = 1 To Len(TabTrouve(1))
            'suppression de la lettre dans la liste
            Fin1 = False
            For j = 1 To NB_MAX_LETTRES_A_TIRER
                With .Cells(LIG_CARTE1, COL_CARTE1 + j - 1)
                    If (.Font.TintAndShade = 0) And Not Fin1 Then
                        'If .Value = UCase(Mid(Cells(1, 1), i, 1)) Then
                        If .Value = UCase(Mid(MotEpele, i, 1)) Then
                            .Font.ColorIndex = .Interior.ColorIndex
                            .Font.ThemeColor = .Interior.ThemeColor
                            .Font.TintAndShade = .Interior.TintAndShade
                            Fin1 = True
                        End If
                    End If
                End With
            Next j
            .Cells(1, 3 + i) = UCase(Mid(MotEpele, i, 1))
            Application.Speech.Speak (.Cells(1, 3 + i))
        Next i
    End With
    Message = NTrouve & " Mot(s) en " & Len(TabTrouve(1)) & " lettre(s)"
    For i = 1 To NTrouve
        Message = Message & vbCrLf & "   - " & TabTrouve(i)
    Next i
    MsgBox Message, , "Liste des Mots trouvés"
       
    Application.EnableEvents = True

End Sub

Regarde la pièce jointe 1226881

Pourriez-vous partagez également votre version ici ?

 

[crocrocro]

Pourriez-vous partagez également votre version ici ?

en pj ma version.
Le fichier étant trop volumineux, j'ai dû alléger la feuille dictionnaire (à l'origine plus de 300 000 mots) qui ne contient plus que des mots de 6 ou 7 lettres.
Quelques explications
C'est un fichier que j'ai mis au point il y a quelques années et que j'ai adapté pour coller à votre algo (pour le timer et la solution)
Pour les cartes du sabot, j'ai utilisé la fréquence des lettres dans les mots de la langue française (voir feuille Cartes). Les lettres déjà tirées sont retirées du sabot.
Le nombre de lettres à tirer est paramétrée (constante NB_MAX_LETTRES_A_TIRER) avec un maximum de 12 lettres.
La durée est paramétrée (constante DUREE_INIT)
Le bouton Charger Dictionnaire permet de charger un dictionnaire au format texte dans la feuille Dictionnaire (je ne l'ai pas retesté)
La cellule P1 (police en blanc) est utilisée pour alimenter le Plateau des lettres tirées. Il permet de forcer des valeurs pour d'éventuels tests !
Les différents boutons de la feuille principale se passent de commentaires.
Go ... déclenche le chrono
Solution ... recherche les mots possibles, épelle le 1er mot le plus long trouvé, affiche en ligne 1 les cartes correspondantes, affiche un message avec la liste des mots trouvés de même longueur que le plus long

 

[halecs93]

en pj ma version.
Le fichier étant trop volumineux, j'ai dû alléger la feuille dictionnaire (à l'origine plus de 300 000 mots) qui ne contient plus que des mots de 6 ou 7 lettres.
Quelques explications
C'est un fichier que j'ai mis au point il y a quelques années et que j'ai adapté pour coller à votre algo (pour le timer et la solution)
Pour les cartes du sabot, j'ai utilisé la fréquence des lettres dans les mots de la langue française (voir feuille Cartes). Les lettres déjà tirées sont retirées du sabot.
Le nombre de lettres à tirer est paramétrée (constante NB_MAX_LETTRES_A_TIRER) avec un maximum de 12 lettres.
La durée est paramétrée (constante DUREE_INIT)
Le bouton Charger Dictionnaire permet de charger un dictionnaire au format texte dans la feuille Dictionnaire (je ne l'ai pas retesté)
La cellule P1 (police en blanc) est utilisée pour alimenter le Plateau des lettres tirées. Il permet de forcer des valeurs pour d'éventuels tests !
Les différents boutons de la feuille principale se passent de commentaires.
Go ... déclenche le chrono
Solution ... recherche les mots possibles, épelle le 1er mot le plus long trouvé, affiche en ligne 1 les cartes correspondantes, affiche un message avec la liste des mots trouvés de même longueur que le plus long

j apprécie beaucoup le mot épelé et la prononciation complète de celui ci

 

[crocrocro]

Les fonctions de voix ont fait de gros progrès. Speak a un rendu de la voix assez naturel, sans être parfait.
Pour rendre le jeu "joueur non-voyant" compatible, il suffit d'ajouter une ligne Speak dans PiocheVoyelle, PiocheConsonne et Go comme indiqué dans le code ci-dessous

Sub Go()
'--- Démarrer le timer ---
    Dim i As Integer
    Dim TempsRestant As Integer
    TempsRestant = DUREE_INIT

    ' Boucle de décompte
    For i = TempsRestant To 0 Step -1
        Sheets(f_PRINCIPAL).Shapes("CHRONO_CERCLE").TextFrame.Characters.Text = i
        DoEvents  ' Permet au UserForm de rester réactif
        Application.Wait Now + TimeValue("00:00:01") ' Pause 1 seconde
    Next i

    'Beep
    Application.Speech.Speak "Les " & DUREE_INIT & "secondes sont écoulées"
    
    ActiverBouton Worksheets(f_PRINCIPAL).Shapes("BoutonSolution")
End Sub
Function PiocheVoyelle() As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
    Randomize
    With Sheets(f_CARTES)
        l = Int((Range("TOTAL_VOYELLES")) * Rnd) + 1
        For i = Len(VOYELLES) To 1 Step -1
            j = i
            If l <= .Cells(6, j) Then
                PiocheVoyelle = .Cells(1, j)
                k = j
            End If
        Next i
        .Cells(5, k) = .Cells(5, k) - 1
        Application.Speech.Speak PiocheVoyelle
    End With
End Function

Function PiocheConsonne() As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
    Randomize
    With Sheets(f_CARTES)
        l = Int((Range("TOTAL_CONSONNES")) * Rnd) + 1
        For i = Len(CONSONNES) To 1 Step -1
            j = i + Len(VOYELLES)
            If l <= .Cells(6, j) Then
                PiocheConsonne = .Cells(1, j)
                k = j
            End If
        Next i
        .Cells(5, k) = .Cells(5, k) - 1
        Application.Speech.Speak PiocheConsonne
    End With
End Function

Pour ce qui est des suggestions de jeu à 2 joueurs hors connexion, La présentation ensuite est une histoire de goût.
Vous devez pouvoir trouver ce qui vous convient dans le jeux avec comptage de points que l'on trouve certainement dans Ressources ou ailleurs (je n'ai pas regardé). Il suffit d'adapter le code à votre goût.
Et pour ce qui concerne la façon de prendre en compte la solution des 2 joueurs, le plus simple selon moi, est d'avoir une 1ère étape manuelle, chaque joueur, tant que le temps n'est pas écoulé, note sur un papier sa solution.
A la fin du temps écoulé, les 2 joueurs montrent leur solution.
Un bouton "Joueur 1" ouvre un userform pour la saisie du mot en majuscule non accentué du joueur 1. Un bouton Valider du userform contrôle l'existence du mot dans la colonne B de la feuille Dictionnaire et l'utilisation correcte des lettres tirées. Si Ok on ajoute le nombre de lettres du mot au compteur du joueur 1.
Idem avec un bouton "Joueur 2".

 

[crocrocro]

En pj, mon fichier précédent avec quelques adaptations, essentiellement pour prendre en compte les solutions de 2 joueurs avec 2 boutons qui ouvrent non pas un userform mais une simple boite de dialogue.
Le mot saisi (casse et accentuation ignorées) est contrôlé par rapport aux lettres tirées et son existence dans le dictionnaire.
Si le mot trouvé est correct, un message signale simplement que le compteur doit être mis jour.

 

[halecs93]

En pj, mon fichier précédent avec quelques adaptations, essentiellement pour prendre en compte les solutions de 2 joueurs avec 2 boutons qui ouvrent non pas un userform mais une simple boite de dialogue.
Le mot saisi (casse et accentuation ignorées) est contrôlé par rapport aux lettres tirées et son existence dans le dictionnaire.
Si le mot trouvé est correct, un message signale simplement que le compteur doit être mis jour.

Bonjour, et merci. Je regarde tout ceci un peu plus tard.

 

[crocrocro]

Désolé pour les mises à jour à répétition !
en pj mes dernières maj (Ajout des compteurs et d'un bouton Initialisation de la partie)

 

[halecs93]

Désolé pour les mises à jour à répétition !
en pj mes dernières maj (Ajout des compteurs et d'un bouton Initialisation de la partie)
Regarde la pièce jointe 1226923

Ne jamais être désolé 😉

 

[halecs93]

Désolé pour les mises à jour à répétition !
en pj mes dernières maj (Ajout des compteurs et d'un bouton Initialisation de la partie)
Regarde la pièce jointe 1226923

de mon côté... j'obtiens ce type d'erreur.... du fait de la version excel utilisée ? (qui semble venir da la ligne : ".Cells(5, k) = .Cells(5, k) - 1"