Excel / VBA - jocul Boggle

Regulile jocului

După cum sa explicat pe Wikipedia ... // en.wikipedia.org/wiki/Boggle:

"Jocul începe prin tremurând o tavă acoperită de șaisprezece zaruri cubice, fiecare cu o altă literă tipărită pe fiecare latură a sa, iar zarurile se așează într-o tavă de 4x4 astfel încât numai litera de sus a fiecărui cub să fie vizibilă. grilă, se începe un cronometru de nisip de trei minute și toți jucătorii încep simultan faza principală de joc.

Fiecare jucător caută cuvinte care pot fi construite din literele cuburilor adiacente, unde cuburile "adiacente" sunt cele învecinate orizontal, vertical sau diagonal. Cuvintele trebuie să aibă o lungime de cel puțin trei litere, pot include singular și plural (sau alte forme derivate) separat, dar nu pot folosi același cub de litere mai mult de o singură dată pentru fiecare cuvânt. Fiecare jucător înregistrează toate cuvintele pe care le găsește scriind pe o foaie de hârtie privată. După ce au trecut trei minute, toți jucătorii trebuie să se oprească imediat și jocul intră în faza de scor. "

Cerințe preliminare

În registrul de lucru Boggle.xls, aveți nevoie de o grilă pentru a găzdui 16 litere. Pentru a face acest lucru, vom numi o serie de celule 4X4, în exemplul D2: G5:

Introduceți un nume definit:

Meniu: introducere

Alegere: Nom

Faceți clic pe: Définir

Numele din registrul de lucru => tip: grilă

Se referă la => introduceți: Feuil1! $ D $ 2: $ G $ 5

Dați clic pe Adăugați.

Codurile VBA

 Opțiunea Explicit Modulul "Variabile de dimensiune" Dim ListeMoturi () Ca șir alfabet Dim (25) Grila Dim (1 până la 4, 1 până la 4) Dim T_Out () Dim Indicator & Numocol, ("C10: H65536"), care se referă la o serie de fișiere de lucru ("Feuil2"). .Cpt = cpt + 0 pentru i = 1 la 4 pentru j = 1 la 4 dacă celulele (i + 1, j + 3) "" 1 Următor j Următor i Dacă cpt 16 Apoi MsgBox "Veillez à bien remplir la grill", vbCritical: Exit Sub Pentru NumCol = 2 Pentru 7 ListerMots Wsh, NumCol RetirerMotsLettresManquantes MotsDansGrille Înainte Pentru i = 3 până la 8 NbreMotsTrouves = NbreMotsTrouves + (Coloane ) .Find ("*",,, xlByColumns, xlPrevious) .Row - 9) Foi următoare ("Feuil1"). des comandă, comandant deputat (i) = Chr (65 + i) Înainte de i = 1 până la 4 Pentru j = 1 până la 4 Randomize numer = (Numerotate + numar + numar +) Daca numarul <0 Atunci numer = numarul + 5 grila (i, j) = alfabetul (numarul) 4 Pentru j = 1 până la 4 celule (i + 1, j + 3) = grila (i, j) Următorul j Următor i End Sub ' Sheets ("Feuil1") Gama ("C10: H65536") Clear Sheets ("Feuil1" Folosiți fișierele de căutare pentru fișierele Feuil2 Sub ListerMots (Shah ca fișă de lucru, ByVal Col As Integer) Dim i &, j & Erase ListeMoturi cu Sh Pentru i = 0 în .Columns (Col) .Find ("*", xlByColumns, xlPrevious) .Red ReDim păstrați ListeMoturi (j) ListeMot (j) = .Cells (i + 2, Col) j = j + 1 Următorul sfârșit cu MotsTraites = MotsTraites + UBound (ListeMots) End Sub 'Enlève de la li () Dim ListeMotsTemp () As String, lettr $, mot $ Dim i &, j &, k &, test În calitate de Boolean Dim MonDico1 As Object, MonDico2 Ca obiect, c lettresutilisees = Interval ("grilă") '-----> Meniu Inserție / Noms / Set Définir MonDico1 = CreateObject ("Scripting.Dictionary") Pentru fiecare c În lettresutilisees MonDico1 (c) "Next c Setați MonDico2 = CreateObject (" Scripting.Dictionary ") Pentru fiecare c În alfabet Dacă nu MonDico1.Exists (c) Apoi MonDico2 (c) =" "Următor c lettresmanquantes = Application.Transpose (MonDico2.Keys) ListeMotsTemp = Sterge ListeMoturi Pentru i = 0 Pentru UBound (ListeMotsTemp) mot = ListeMotsTemp (i) Pentru j = 1 Pentru UBound (lettresmanquantes) lettr = lettresmanquantes (j, 1) InStr (mot, lettr) = 0 Test = Exit fals pentru sfârșit Dacă următoarea j Dacă se testează atunci ReDim păstrează ListeMot (k) ListeMot (k) = ListeMotsTemp (i) k = k + 1 Sfârșit Dacă următoarea i End Sub 'Proc (), dimensiune și dim cellulesUtilizări ca obiect pentru i = 1 până la 4 pentru j = 1 4 grilă (i, j) = Celule (i, j) Următoarele j Următoarele i Pentru fiecare moto În Setul de ListeMoturi rngTrouve = Gama ("grila") Cells.Find Erase T_Out Indice = 0 ReDim Conserve T_Out (Indica) T_Out (Indic) = rngTrouve.Address Set CellulesUtilisees = CreateObject ("Scripting.Dictionary") CellulesVoisines CellulesUtilisees, rngTrouve, mot, 1 firstAddress = rngTrouve.Address Do Set rngTrouve = (indice) T_Out (Ind) = rngTrouve.Address Set CellulesUtilisees = CreateObject ("Scripting.Dictionary") CellulesVoisines CellulesUtilisees, rngTrouve, mot, 1 Dacă Indic = Len (mot) - 1 Apoi Flag = Adevărat Pentru Indic = Lbound (T_Out) Pentru UBound (T_Out) Dacă Range (T_Out (Ind))., Indicativ + 1, 1) Apoi, Flag = False: Ieșire pentru următorul indicator Else Flag = Sfârșitul False Dacă Dacă Flag Apoi ieșiți Nu faceți buclă în timp ce nu rngTrouve este nimic și rngTrouve.Address firstAddress End Dacă Dacă Flag Apoi ReDim păstra MotsTouvesDansGrille (k) MotsTouvesDansGrille (k) = mot k = k + 1 Sfârșit Dacă următoarea mot Dacă k 0 Apoi pentru k = Lbound (MotsTouvesDansGrille) la foile UBound (MotsTouvesDansGrille) (Feuil1) Celule (10+ k, NumCol + 1) = MotsTouvesDansGrille k) Următoarea k End Dacă End Sub 'En fonction des cellules voisines Sub CellulesVoisines (ByRef Obj, CelInitiale, Strmot, niveau) Dim Cel ca Range, Plage As Range, Flag As Boolean, c La Error Resume Next Set Plage = Range (CelInitiale (1, -1), CelInitiale.Offset (1, 1)) Obj.Add CelInitiale.Address, Mid (Strmot, niveau, 1) Pentru Dacă Cel.Value = Mid (Strmot, niveau + 1, 1) Apoi Flag = Adevărat pentru fiecare c În Obj.Keys Dacă c = Cel.Address Apoi Flag = False Următor Dacă Flag Then Obj.Add Cel.Address, Mid Strmot, niveau + 1, 1) Indicator = Indicator + 1 ReDim Păstrați T_Out (Indicație) T_Out (Indic) = Cel.Address CellulesVoisines Obj, Cel, Strmot, niveau + 1 Sfârșit Dacă Sfârșit Dacă Next Cel End Sub Adăugați la un modul standard: F11 Introducere / Modul.

notițe

Mai presus de toate, acordați o atenție deosebită coloanelor din foaia 2: coloana B (de la B2 la BX: cuvinte cu 3 litere), coloana C (de la C2 la Cx: cuvintele de 4 litere), ....., coloana G la Gx: cuvinte cu 8 litere)