Excel / VBA - le jeu Boggle

Les règles du jeu

Comme expliqué sur Wikipedia ... // fr.wikipedia.org/wiki/Boggle:

"Le jeu commence par secouer un plateau couvert de seize dés cubiques, chacun avec une lettre différente imprimée sur chacun de ses côtés. Les dés se déposent dans un plateau 4x4 de sorte que seule la lettre du haut de chaque cube soit visible. Dans la grille, un chronomètre de trois minutes est lancé et tous les joueurs entament simultanément la phase principale du jeu.

Chaque joueur recherche des mots pouvant être construits à partir des lettres de cubes séquentiellement adjacents, les cubes "adjacents" étant ceux adjacents horizontalement, verticalement ou en diagonale. Les mots doivent comporter au moins trois lettres, peuvent comprendre le singulier et le pluriel (ou d’autres formes dérivées) séparément, mais ne peuvent pas utiliser le même cube de lettres plus d’une fois par mot. Chaque joueur enregistre tous les mots qu’il trouve en écrivant sur une feuille de papier privée. Au bout de trois minutes, tous les joueurs doivent immédiatement cesser d'écrire et le jeu entre en phase de score. "

Conditions préalables

Dans le classeur Boggle.xls, vous avez besoin d’une grille pouvant contenir 16 lettres. Pour ce faire, nous allons nommer une plage de cellules 4X4, dans l'exemple D2: G5:

Insérer un nom défini:

Menu: Insertion

Choix: Nom

Cliquez: Définir

Noms dans le classeur => type: calandre

Se rapporte à => entrer: Feuil1! $ D $ 2: $ G $ 5

Cliquez sur Ajouter.

Codes VBA

 Option Explicit Module 'Variables de dimension' Dim Dim ListeMots () En tant que chaîne Alphabet Dim (25) Dim grille (1 à 4, 1 à 4) Dim T_Out () Dim Ind &, NumCol &, MotsTraites As Long 'procédure principale servant d'appel aux autres procédures Sub Aleatoire_ProcedurePrincipale () Dim Wsh En tant que feuille de travail, NbreMotsTrouves As Long, i &, j &, cpt MotsTraites = 0 Définir Wsh = ThisWorkbook.Worksheets ("Feuil2"). Feuilles ("Feuil1"). Gamme ("Feuil1"). Gamme ("C10: H65536)" .Clear Sheets ("Feuil1"). Range ("E7"). ClearContents cpt = 0 pour i = 1 à 4 pour j = 1 à 4 si cellules (i + 1, j + 3) "" alors cpt = cpt + 1 Suivant j Suivant i Si cpt 16 Puis MsgBox "viderCritique: Sortie Sous Pour NumCol = 2 à 7 ListerMots Wsh, NumColeurMotsLettresManquantes MotsDansGrille Suivant Pour i = 3 à 8 NbreMotsTrouves = NbreMotsTrouves + (Columns) ) .Find ("*",,,, xlByColumns, xlPrevious) .Row - 9) Feuilles suivantes ("Feuil1"). Range ("E7") = "Nombre de mots trouvés:" & NbreMotsTrouves End Sub 'Tirage au sort des lettres, à commander depuis un bouton dans la feuille Sous Tirage () Dim i &, j & num, y Pour i = 0 à 25 alphabet (i) = Chr (65 + i) Suivant Pour i = 1 à 4 Pour j = 1 à 4 Randomize numer = CInt (25 * Rnd) - 5 Si num> 25 Alors num = num - num + 10 Si num <0 Ensuite num = 5 + calandre (i, j) = alphabet (numer) Suivant j Suivant i Pour i = 1 À 4 Pour j = 1 à 4 cellules (i + 1, j + 3) = calandre (i, j) Suivant j Suivant i Fin Sous efface les lettres et les solutions, à commander depuis un bouton dans la feuille Sub Efface () Feuilles ("Feuil1"). Plage ("C10: H65536"). Clear Sheets ("Feuil1"). Plage ("E7"). ClearContents Feuilles ("feuil1"). Plage ("grille"). ClearContents End Sub ' Liste tous les mots (solutions) dans la feuille Feuil2 Sous ListerMots (Sh comme feuille de calcul, ByVal Col comme entier) Dim i &, j & Erase ListeMots avec Sh Pour i = 0 à .Colonnes (Col) .Find ("*",, , xlByColumns, xlPrevious) .Row ReDim Conserver ListeMots (j) ListeMots (j) = .Cells (i + 2, Col) j = j + 1 Fin suivant avec MotsTraites = MotsTraites + UBound (ListeMots) Fin Sous 'Enlève de la li Les mots contenant les lettres ne faisant pas partie du tirage Sous-modèlesMettresLettres () Dim lettres utilisées (), lettresmanquantes () Dim ListeMotsTemp () As String, lettr $, mot $ Dim i &, j &, k &, test As Boolean Dim MonDico1 As Object, MonDico2 En tant qu'objet, c lettres utilisees = Range ("grille") '-----> Insertion de menu / Noms / Définir la valeur MonDico1 = CreateObject ("Scripting.Dictionary") pour chaque c En lettres utiliséeses MonDico1 (c) = " "C Suivant MonDico2 = CreateObject (" Scripting.Dictionary ") pour chaque c en alphabet Si pas MonDico1.Exists (c) Then MonDico2 (c) =" "c suivant lettresmanquantes = Application.Transpose (MonDico2.Keys) ListeMotsTemp = ListeMots Effacer ListeMots Pour i = 0 à UBound (ListeMotsTemp) mot = ListeMotsTemp (i) Pour j = 1 À UBound (lettresmanquantes) lettr = lettresmanquantes (j, 1) Si InStr (mot, lettr) = 0 Alors test = Vrai test True = False Quitter pour Fin si Suivant j Si test, puis ReDim Conserver ListeMots (k) ListeMots (k) = ListeMotsTemp (i) k = k + 1 End If Next i End Sub 'Proc Durée de la recherche des mots Sub MotsDansGrille () Dim c, mot Dim rngTrouve As Range Dim i &, j &, j &, NumLettre & Dim first Adresse, Drapeau As Boolean Dim MotsTouvesDansGrille (), k & Dim CellulesUtilisees As Object For i = 1 à 4 pour j = 1 To 4 grille (i, j) = Cellules (i, j) Suivant j Suivant i Pour chaque mot Dans ListeMots Définir rngTrouve = Plage ("grille"). Cells.Find (Left (mot, 1)) Si non rngTrouve n’est rien, puis Effacer T_Out Indic = 0 ReDim Conserver T_Out (Indic) T_Out (Indic) = rngTrouve.Adresse Définir CellulesUtilisees = CreateObject ("Scripting.Dictionary") CellulesVoisines CellulesUtilisees, rngTrouve, mot, 1 firstAddress = rngRouve.Address = Racine grille "). Cells.FindNext (rngTrouve) Effacer T_Out Indicateur = 0 ReDim Conserver T_Out (Ind) T_Out (Ind) = rngTrouve.Adresse Définir CellulesUtilise = CreateObject (" Scripting.Dictionary ") CellulesVoisines CellulesUtilisees, rngTrouve, produit = Len (mot) - 1 Alors drapeau = True pour Indic = LBound (T_Out) à UBound (T_Out) Si Plage (T_Out (Ind)). Valeur Mid (mot, Indic + 1, 1) Then Flag = False: Quitter pour Next Indic Else Flag = False End If If Flag puis Exit Do Loop tant que rngTrouve n'est rien et rngTrouve.Adresse firstAddress End If Si flag Puis ReDim Conserver MotsTouvesDansGrille (k) MotsTouvesDansGrille (k) = mot k = k + 1 Fin Si Suivant mot si k 0 alors pour k = L lié (MotsTouvesDansGrille) à UBound (MotsTouvesDansGrille) Feuilles ("Feuil1"). Cellules (10 + k, NumCol + 1) = MotsTouvesDansGrille ( k) Suivant k End If End Sub CellulesVoisines (ByRef Obj, CelInitiale, Strmot, niveau) Dim Cel As Range, Plage As Range, Drapeau As Boolean, c Sur erreur Reprendre Next Set Plage = Range (CelInitiale .Offset (-1, -1), CelInitiale.Offset (1, 1)) Obj.Add CelInitiale.Address, Mid (Strmot, niveau, 1) Pour chaque cel de la plage Si Indic + 1 = Len (Strmot), puis quittez. Pour If Cel.Value = Mid (Strmot, niveau + 1, 1) Puis Flag = True pour chaque c dans Obj.Keys If c = Cel.Address Then Flag = Faux Suivant Si Flag Then Obj.Add Cel.Address, Mid ( Strmot, niveau + 1, 1) Ind = Ind + 1 ReDim Conserve T_Out (Ind) T_Out (Ind) = Cel.Address CellulesVoisines Obj, Cel, Strmot, niveau + 1 End If End Si Next Cel End Sub Ajouter à un module standard: A partir de votre feuille de calcul, appuyez sur ALT + F11 Insert / Module.

Remarques

Surtout, faites particulièrement attention aux colonnes de la feuille Sheet2: colonne B (de B2 à BX: mots de 3 lettres), colonne C (de C2 à Cx: mots de 4 lettres), ....., colonne G (de G2). to Gx: mots de 8 lettres)