Jeu sous Excel - VBA : "Le Boggle"

Le jeu du Boggle sous Excel, avec VBA...

Règle du jeu

Tirée de l'article wikipédia.
Le jeu commence par le mélange d'un plateau (carré) de 16 dés à 6 faces, généralement en le secouant. Chaque dé possède une lettre différente sur chacune de ses faces. Les dés sont rangés sur le plateau 4 par 4, et seule leur face supérieure est visible. Après cette opération, un compte à rebours de 3 minutes est lancé et tous les joueurs commencent à jouer.
Chaque joueur cherche des mots pouvant être formés à partir de lettres adjacentes du plateau. Par «adjacentes», il est sous-entendu horizontalement, verticalement, ou en diagonale. Les mots doivent être de 3 lettres au minimum, peuvent être au singulier ou au pluriel, conjugués ou non, mais ne doivent pas utiliser plusieurs fois le même dé pour le même mot. Les joueurs écrivent tous les mots qu'ils ont trouvés sur leur feuille personnelle. Après les 3 minutes de recherche, les joueurs doivent arrêter d'écrire et le jeu entre dans la phase de calcul des points.
Si deux joueurs ou plus ont trouvé le même mot, il est rayé des listes le contenant. Tous les joueurs doivent vérifier la validité d'un mot. Après avoir éliminé les mots communs aux listes des joueurs, les points sont attribués suivant la taille des mots trouvés. Le gagnant est le joueur ayant le plus grand nombre de points.
Mots de 3 et 4 lettres = 1 point, mots de 5 lettres = 2 points, mots de 6 lettres = 3 points, mots de 7 lettres = 5 points, mots de 8 lettres = 11 points.

Pré-requis :

Dans votre classeur Boggle.xls, il vous faut une grille pour accueillir les 16 lettres. Pour cela, nous allons nommer une plage de 4 cellules par 4 cellules, dans l'exemple D2 :G5 comme suit :

• Insérer un nom défini :
  • Menu : Insertion
  • Choix : Nom
  • Cliquer sur Définir

Noms dans le classeur => saisir : grille
Fait référence à => saisir : =Feuil1!$D$2:$G$5
Cliquer sur Ajouter.

Les codes VBA

A insérer dans un module standard :
Depuis votre feuille de calcul, taper ALT+F11, Insertion/Modules.

 Option Explicit      
'Variables de dimension « module »      
Dim Adresses(), p&   
Dim ListeMots() As String   
Dim alphabet(25)   
Dim grille(1 To 4, 1 To 4)   
Dim t_Out()   
Dim Indic&, NumCol&, MotsTraites As Long   

'Procédure principale servant d'appel aux autres procédures      
Sub Aleatoire_ProcedurePrincipale()   
Dim Wsh As Worksheet, NbreMotsTrouves As Long, i&, j&, cpt   

MotsTraites = 0   
Set Wsh = ThisWorkbook.Worksheets("Feuil2")   

Sheets("Feuil1").Range("C10:H65536").Clear   
Sheets("Feuil1").Range("E7").ClearContents   
cpt = 0   
For i = 1 To 4   
    For j = 1 To 4   
        If Cells(i + 1, j + 3) <> "" Then cpt = cpt + 1   
    Next j   
Next i   
If cpt <> 16 Then MsgBox "Veillez à bien remplir la grille", vbCritical: Exit Sub   
For NumCol = 2 To 7   

ListerMots Wsh, NumCol   

RetirerMotsLettresManquantes   

MotsDansGrille   
Next   
For i = 3 To 8   
    NbreMotsTrouves = NbreMotsTrouves + (Columns(i).Find("*", , , , xlByColumns, xlPrevious).Row - 9)   
Next   
Sheets("Feuil1").Range("E7") = "Nombre de mots trouvés : " & NbreMotsTrouves   
End Sub      

'Tirage au sort des lettres (selon la règle du bogle), à commander depuis un bouton dans la feuille      
Sub TirageMoinsAleatoire()   
Dim i&   
For i = 0 To 25   
    alphabet(i) = Chr(65 + i)   
Next   
Randomize   
Range("D2") = Mid("ETUKNO", CInt(Int((6 * Rnd()) + 1)), 1)   
Randomize   
Range("D3") = Mid("EVGTIN", CInt(Int((6 * Rnd()) + 1)), 1)   
Randomize   
Range("D4") = Mid("IELRUW", CInt(Int((6 * Rnd()) + 1)), 1)   
Randomize   
Range("D5") = Mid("DECAMP", CInt(Int((6 * Rnd()) + 1)), 1)   
Randomize   
Range("E2") = Mid("EHIFSE", CInt(Int((6 * Rnd()) + 1)), 1)   
Randomize   
Range("E3") = Mid("RECALS", CInt(Int((6 * Rnd()) + 1)), 1)   
Randomize   
Range("E4") = Mid("ENTDOS", CInt(Int((6 * Rnd()) + 1)), 1)   
Randomize   
Range("E5") = Mid("OFXRIA", CInt(Int((6 * Rnd()) + 1)), 1)   
Randomize   
Range("F2") = Mid("NAVEDZ", CInt(Int((6 * Rnd()) + 1)), 1)   
Randomize   
Range("F3") = Mid("EIOATA", CInt(Int((6 * Rnd()) + 1)), 1)   
Randomize   
Range("F4") = Mid("GLENYU", CInt(Int((6 * Rnd()) + 1)), 1)   
Randomize   
Range("F5") = Mid("BMAQJO", CInt(Int((6 * Rnd()) + 1)), 1)   
Randomize   
Range("G2") = Mid("TLIBRA", CInt(Int((6 * Rnd()) + 1)), 1)   
Randomize   
Range("G3") = Mid("SPULTE", CInt(Int((6 * Rnd()) + 1)), 1)   
Randomize   
Range("G4") = Mid("AIMSOR", CInt(Int((6 * Rnd()) + 1)), 1)   
Randomize   
Range("G5") = Mid("ENHRIS", CInt(Int((6 * Rnd()) + 1)), 1)   
End Sub   

'Efface les lettres et les solutions, à commander depuis un bouton dans la feuille      
Sub Efface()      
Sheets("Feuil1").Range("C10:H65536").Clear      
Sheets("Feuil1").Range("E7").ClearContents      
Sheets("feuil1").Range("grille").ClearContents      
End Sub      

'Liste tous les mots (solutions) dans la feuille Feuil2      
Sub ListerMots(Sh As Worksheet, ByVal Col As Integer)      
Dim i&, j&      

Erase ListeMots      
With Sh      
    For i = 0 To .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row      
        ReDim Preserve ListeMots(j)      
        ListeMots(j) = .Cells(i + 2, Col)      
        j = j + 1      
    Next      
End With      
MotsTraites = MotsTraites + UBound(ListeMots)      
End Sub      

'Enlève de la liste, les mots contenant des lettres ne faisant pas partie du tirage      
Sub RetirerMotsLettresManquantes()      
Dim lettresutilisees(), lettresmanquantes()      
Dim ListeMotsTemp() As String, lettr$, mot$      
Dim i&, j&, k&, test As Boolean      
Dim MonDico1 As Object, MonDico2 As Object, c      

lettresutilisees = Range("grille") '-----> Menu Insertion/Noms/Définir      
Set MonDico1 = CreateObject("Scripting.Dictionary")      
For Each c In lettresutilisees      
    MonDico1(c) = ""      
Next c      
Set MonDico2 = CreateObject("Scripting.Dictionary")      
For Each c In alphabet      
    If Not MonDico1.Exists(c) Then MonDico2(c) = ""      
Next c      
lettresmanquantes = Application.Transpose(MonDico2.Keys)      
ListeMotsTemp = ListeMots      
Erase ListeMots      
For i = 0 To UBound(ListeMotsTemp)      
    mot = ListeMotsTemp(i)      
    For j = 1 To UBound(lettresmanquantes)      
        lettr = lettresmanquantes(j, 1)      
        If InStr(mot, lettr) = 0 Then      
            test = True      
        Else      
            test = False      
            Exit For      
        End If      
    Next j      
    If test Then      
        ReDim Preserve ListeMots(k)      
        ListeMots(k) = ListeMotsTemp(i)      
        k = k + 1      
    End If      
Next i      
End Sub      

'Procédure de recherche des mots  
Sub MotsDansGrille()     
Dim MotsTouvesDansGrille(), k&, l& 
Dim Cel As Range, mot, firstAddress$, a$, c, dico As Object, mondico As Object 

For Each mot In ListeMots 
On Error Resume Next 
Erase Adresses 
p = 0 
    Set Cel = Range("D2:G5").Cells.Find(Left(mot, 1)) 
    If Not Cel Is Nothing Then 
        ReDim Preserve Adresses(p) 
        Adresses(p) = Cel.Address 
        p = p + 1 
        CellulesVoisines Cel, mot, 1 
        If UBound(Adresses) = Len(mot) - 1 Then 
            Set dico = CreateObject("Scripting.Dictionary") 
            For Each c In Adresses 
                If Not dico.exists(c) Then 
                    dico(c) = c 
                Else 
                    GoTo motsuivant 
                End If 
            Next c 
            ReDim Preserve MotsTouvesDansGrille(k) 
            MotsTouvesDansGrille(k) = mot 
            GoTo motsuivant 
            k = k + 1 
        End If 
        firstAddress = Cel.Address 
        Do 
            Set Cel = Range("D2:G5").Cells.FindNext(Cel) 
            Erase Adresses 
            p = 0 
            ReDim Preserve Adresses(p) 
            Adresses(p) = Cel.Address 
            p = p + 1 
            CellulesVoisines Cel, mot, 1 
            If UBound(Adresses) = Len(mot) - 1 Then 
                Set dico = CreateObject("Scripting.Dictionary") 
                For Each c In Adresses 
                    If Not dico.exists(c) Then 
                        dico(c) = c 
                    Else 
                        GoTo motsuivant 
                    End If 
                Next c 
                ReDim Preserve MotsTouvesDansGrille(k) 
                MotsTouvesDansGrille(k) = mot 
                k = k + 1 
            End If 
        Loop While Not Cel Is Nothing And Cel.Address <> firstAddress 
    End If 
motsuivant: 
Next mot 
If k <> 0 Then 
  Set mondico = CreateObject("Scripting.Dictionary") 
    For k = LBound(MotsTouvesDansGrille) To UBound(MotsTouvesDansGrille) 
        mondico(MotsTouvesDansGrille(k)) = "" 
    Next k 
Sheets("Feuil1").Cells(10, NumCol + 1).Resize(mondico.Count, 1) = Application.Transpose(mondico.keys) 
End If      
End Sub 
'En fonction des cellules voisines - procédure récursive.      
Sub CellulesVoisines(CelInitiale, Strmot, niveau)   
Dim Cel As Range, Plage As Range, Lettr As Byte, cpt&, flag As Boolean, elem   

Set Plage = Range(CelInitiale.Offset(-1, -1), CelInitiale.Offset(1, 1))   
cpt = 0   
For Each Cel In Plage   
    If p > Len(Strmot) - 1 Or niveau = Len(Strmot) Then Exit For   
    cpt = cpt + 1   
    flag = False   
    For Each elem In Adresses   
        If Cel.Address = elem Then flag = True: Exit For   
    Next   
    If Cel.Value = Mid(Strmot, niveau + 1, 1) And flag = False Then   
        ReDim Preserve Adresses(p)   
        Adresses(p) = Cel.Address   
        p = p + 1   
        niveau = niveau + 1   
        CellulesVoisines Cel, Strmot, niveau   
    End If   
Next Cel   
If cpt = 9 Then niveau = niveau - 1: p = p - 1   
End Sub   

Précautions d'emploi

Surtout, respectez les colonnes en Feuil2 : Colonne B, de B2 à Bx : mots de 3 lettres, Colonne C, de C2 à Cx : mots de 4 lettres, ..... , Colonne G, de G2 à Gx : mots de 8 lettres.

Le fichier est assez lourd (3Mo), mais c'est du au fait qu'il contient une liste de plus de 80 000 mots...

Téléchargement

Vous pouvez télécharger le classeur source exemple.

En plus du classeur ci-dessous, vous pourrez trouver en suivant ce lien, le jeu sur plateau (UserForm). Dans celui-ci, faites une partie contre l'ordinateur... Ne vous en faites pas, il ne trouve pas tous les mots à chaque fois!
Si toutefois ceux-ci n'étaient plus disponibles sur cjoint, merci de me le faire savoir en m'envoyant un MP ici, cliquez sur « Lui écrire un message »

Bon jeu à toutes et tous...

A voir également

Communautés d'assistance et de conseils.

• Forum
• Forum VB / VBA
• Forum Excel
• Forum Outlook

Ce document intitulé « Jeu sous Excel - VBA : "Le Boggle" » issu de CommentCaMarche (www.commentcamarche.net) est mis à disposition sous les termes de la licence Creative Commons. Vous pouvez copier, modifier des copies de cette page, dans les conditions fixées par la licence, tant que cette note apparaît clairement.