Excel / VBA - Boggle spillet

Reglene i spillet

Som forklart på Wikipedia ... // en.wikipedia.org/wiki/Boggle:

"Spillet begynner med å riste en dekkbakke med seksten kubiske terninger, hver med et annet brev trykt på hver sin side. Terningene legger seg inn i en 4x4-skuff slik at kun toppbokstavene til hver terning er synlige. Etter at de har slått seg inn i nettet, en tre minutters sandtimer er startet, og alle spillere starter samtidig hovedfasen av spillet.

Hver spiller søker etter ord som kan konstrueres fra bokstavene til sekvensielt tilstøtende kuber, hvor "tilstøtende" kuber er de horisontalt, vertikalt eller diagonalt nærliggende. Ord må være minst tre bokstaver lenge, kan inneholde singular og flertall (eller andre avledede former) separat, men kan ikke bruke samme bokstavskube mer enn en gang per ord. Hver spiller registrerer alle ordene han eller hun finner ved å skrive på et eget ark. Etter at tre minutter er gått, må alle spillere straks slutte å skrive og spillet går inn i scoringfasen. "

Forutsetninger

I Boggle.xls arbeidsboken trenger du et rutenett for å imøtekomme 16 bokstaver. For å gjøre dette skal vi utpeke en rekke 4X4-celler, i eksempelet D2: G5:

Sett inn et definert navn:

Meny: Innsetting

Valg: Nom

Klikk: Définir

Navn i arbeidsboken => type: grille

Refererer til => enter: Feuil1! $ D $ 2: $ G $ 5

Klikk på Legg til.

VBA koder

 Alternativ Eksplisitt Variabler de dimensjon «modul» Dim ListMots () Som String Dim alfabet (25) Dim grille (1 til 4, 1 til 4) Dim T_Out () Dim Indikator, NumCol &, MotsTraites As Long 'procédure principale servant d'appel aux autres procédures Sub Aleatoire_ProcedurePrincipale () Dim Wsh som regneark, NbreMotsTrouves så lenge, i & j, cpt MotsTraites = 0 Sett Wsh = ThisWorkbook.Worksheets ("Feuil2") Sheets ("Feuil1"). Område ("C10: H65536") ClearCenter cpt = 0 For i = 1 til 4 For j = 1 til 4 Hvis celler (i + 1, j + 3) "" Så cpt = cpt + 1 Neste j Neste I Hvis cpt 16 Så MsgBox "Veillez à bien remplir la grille", vbCritical: Exit Sub For NumCol = 2 til 7 ListerMots Wsh, NumCol RetirerMotsLettresManquantes MotsDansGrille Neste For i = 3 til 8 NbreMotsTrouves = NbreMotsTrouves + (Kolonner ) .Find ("*,,,, xlByColumns, xlForrige) .Row - 9) Neste ark (" Feuil1 ") .Range (" E7 ") =" Nombre de mots trouvés: "& NbreMotsTrouves End Sub" Tirage au sort des lettres, à commander depuis (i) = Chr (65 + i) Neste For i = 1 til 4 For j = 1 til 4 Randomize numer = Cnt (25 * Rnd) - 5 Hvis tall> 25 Så tall = tall - tall + 10 Hvis tall <0 Så tall = tall + 5 grille (i, j) = alfabet (tall) Neste j Neste jeg For i = 1 Til 4 For j = 1 til 4 celler (i + 1, j + 3) = grille (i, j) Neste j Neste jeg slutter Sub 'Efface les lettres et les solutions, à commander depuis un bouton dans la feuille Sub Efface ("Feuil1"). Område ("C10: H65536"). Rydde ark ("Feuil1"). Område ("E7"). ClearContents Sheets ("feuil1"). Liste tilus les mots (løsninger) dans la feuille Feuil2 Sub ListerMots (Sh som regneark, ByVal Col som helhet) Dim i &, j & Erase ListeMots med Sh For i = 0 Til .Kolumner (Col) .Find ("*",, , xlByColumns, xlPrevious) .Row ReDim Preserve ListMots (j) ListeMots (j) = .Cells (i +2, Col) j = j + 1 Neste Ende Med MotsTraites = MotsTraites + UBound (ListeMots) End Sub "Enlève de la li () Dim ListeMotsTemp () Som String, lettr $, mot $ Dim i &, j &, k &, test Som Boolean Dim MonDico1 As Object, MonDico2 Som Object, c lettresutilisees = Range ("grille") '-----> Menyinnsetting / Noms / Définir Sett MonDico1 = CreateObject ("Scripting.Dictionary") For hver c I lettresutilisees MonDico1 (c) = " "Next c Sett MonDico2 = CreateObject (" Scripting.Dictionary ") For hver c I alfabetet Hvis ikke MonDico1.Exists (c) Så MonDico2 (c) =" "Neste c lettresmanquantes = Application.Transpose (MonDico2.Keys) ListeMotsTemp = ListeMots Slett ListMots For I = 0 Til UBound (ListMotsTemp) mot = ListeMotsTemp (i) For j = 1 Til Ubound (lettresmanquantes) lettr = lettresmanquantes (j, 1) Hvis InStr (mot, lettr) = 0 Så test = True Else test = False Exit for End Hvis neste j Hvis test, fortsetter ReDim ListeMots (k) ListMots (k) = ListeMotsTemp (i) k = k + 1 Slutt hvis neste jeg avslutter Sub 'Proc Dure de recherche des mots Sub MotsDansGrille () Dim, mot Dim rngTrouve Som Range Dim i &, j &, NumLettre & Dim firstAddress, Flagg som Boolean Dim MotsTouvesDansGrille (), K & Dim CellulesUtilisees Som Object For I = 1 Til 4 For J = 1 Til 4 grille (i, j) = Cells (i, j) Neste j Neste jeg For hver mot I ListeMotsett rngTrouve = Range ("grille"). Cells..Find (Venstre (mot, 1)) Hvis ikke rngTrouve er ingenting da Slett T_Out Indikator = 0 ReDim Bevar T_Out (Indikator) T_Out (Indikator) = RngTrouve.Address Set CellulesUtilisees = CreateObject ("Scripting.Dictionary") CellulesVoisines CellulesUtilisees, rngTrouve, mot, 1 firstAddress = rngTrouve.Address Sett RngTrouve = Range (" grille ") .Celler.FindNeste (rngTrouve) Slett T_Out Indikator = 0 ReDim Bevar T_Out (Indikator) T_Out (Indikator) = RngTrouve.Address Set CellulesUtilisees = CreateObject (" Scripting.Dictionary ") CellulesVoisines CellulesUtilisees, rngTrouve, mot, = Len (mot) - 1 Deretter Flagg = True For Indikator = LBound (T_Out) Til UBound (T_Out) Hvis Range (T_Out (Indikator)). Verdi Mid, Indikasjon + 1, 1) Så Flagg = Falsk: Avslutt For Neste Indikasjon Else Flagg = False End Hvis Hvis Flagg Da Avslutt Gjør Loop While Not RngTrouve Er Ingenting Og RngTrouve.Address FirstAddress End Hvis Hvis Flagg Da ReDim Bevar MotsTouvesDansGrille (k) MotsTouvesDansGrille (k) = mot k = k + 1 End Hvis neste mot Hvis k 0 For k = LBound (MotsTouvesDansGrille) Til UBound (MotsTouvesDansGrille) Ark ("Feuil1"). Celler (10 + k, NumCol + 1) = MotsTouvesDansGrille k) Neste k End Hvis End Sub "En fonksjon av cellene Voisines Sub CellulesVoisines (ByRef Obj, CelInitiale, Strmot, nivå) Dim Cel som Range, Plage som Range, Flagg som Boolean, c På Feil Fortsett Neste Set Plage = Range (CelInitiale .Offset (-1, -1), CelInitiale.Offset (1, 1)) Obj.Add CelInitiale.Address, Mid (Strmot, nivå, 1) For hver Cel i Plage Hvis indik + 1 = Len (Strmot) For If Cel.Value = Mid (Strmot, nivå + 1, 1) Deretter Flagg = True For Hver c I Obj.Keys Hvis c = Cel.Address Then Flag = False Next Hvis Flagg deretter Obj.Add Cel.Address, Mid ( Strmot, nivå + 1, 1) Indikasjon = Indikator + 1 ReDim Preserve T_Out (Indikator) T_Out (Indikator) = Cel.Address CellulesVoisines Obj, Cel, Strmot, nivå + 1 Slutt hvis slutt hvis neste Cel End Sub Legg til i en standardmodul: Fra regnearket trykker du ALT + F11 Sett inn / modul.

Merknader

Vær spesielt oppmerksom på kolonnene i Ark2: Kolonne B (fra B2 til BX: 3 bokstaver), Kolonne C (fra C2 til Cx: 4 bokstaver), ....., Kolonne G (fra G2 til Gx: ord med 8 bokstaver)