Excel / VBA - gra Boggle

Zasady gry

Jak wyjaśniono na Wikipedii ... // pl.wikipedia.org/wiki/Boggle:

„Gra rozpoczyna się od potrząsania zakrytą tacą szesnastu kości sześciennych, z których każda ma inną literę wydrukowaną na każdej ze stron. Kości układają się w tacce 4x4, tak że widoczna jest tylko górna litera każdej kostki. na siatce rozpoczyna się trzy minutowy timer piasku i wszyscy gracze rozpoczynają jednocześnie główną fazę gry.

Każdy gracz szuka słów, które mogą być zbudowane z liter kolejno sąsiadujących kostek, gdzie „sąsiadujące” kostki są tymi sąsiadującymi poziomo, pionowo lub ukośnie. Słowa muszą mieć co najmniej trzy litery, mogą zawierać liczbę pojedynczą i mnogą (lub inne formy pochodne) oddzielnie, ale nie mogą używać tej samej kostki literowej więcej niż raz na słowo. Każdy gracz zapisuje wszystkie znalezione słowa, pisząc na prywatnej kartce papieru. Po upływie trzech minut wszyscy gracze muszą natychmiast przerwać pisanie, a gra wchodzi w fazę punktacji. ”

Wymagania wstępne

W skoroszycie Boggle.xls potrzebujesz siatki, aby pomieścić 16 liter. W tym celu wyznaczymy zakres komórek 4X4 w przykładzie D2: G5:

Wstaw zdefiniowaną nazwę:

Menu: wstawianie

Wybór: Nom

Kliknij: Définir

Nazwy w skoroszycie => wpisz: kratka

Odnosi się do => wprowadź: Feuil1! $ D $ 2: $ G $ 5

Kliknij Dodaj.

Kody VBA

 Opcja Jawny moduł „Zmienne de wymiar” »Dim ListeMots () As String Dim alfabet (25) Dim grille (1 do 4, 1 do 4) Dim T_Out () Dim Indic i, 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") Arkusze ("Feuil1"). Range ("C10: H65536") .Clear Sheets ("Feuil1"). Range ("E7"). ClearContents cpt = 0 Dla i = 1 do 4 Dla j = 1 do 4 If Cells (i + 1, j + 3) "" Następnie cpt = cpt + 1 Następny j Następny i Jeśli cpt 16 Wtedy MsgBox "Veillez à bien remplir la grille", vbCritical: Exit Sub For NumCol = 2 do 7 ListerMots Wsh, NumCol RetirerMotsLettresManquantes MotsDansGrille Następny dla i = 3 do 8 NbreMotsTrouves = NbreMotsTrouves + (kolumny (i ) .Find ("*",,,, xlByColumns, xlPrevious) .Row - 9) Następne arkusze ("Feuil1"). Range ("E7") = "Nombre de mots trouvés:" & NbreMotsTrouves End Sub 'Tirage au sort des lettres, à dowódcy dowódcy un bouton dans la feuille Sub Tirage () Dim i &, j &, numer, y Dla i = 0 Do 25 alfabet (i) = Chr (65 + i) Następny Dla i = 1 do 4 Dla j = 1 do 4 Randomize numer = CInt (25 * Rnd) - 5 Jeśli numer> 25 Następnie numer = numer - numer + 10 Jeśli numer <0 Następnie numer = numer + 5 kratka (i, j) = alfabet (numer) Następny j Następny i Dla i = 1 Do 4 Dla j = 1 do 4 komórek (i + 1, j + 3) = kratka (i, j) Następny j Następny i End Sub 'Efekt les lettres i les solutions, à commander depuis un bouton dans la feuille Sub Efface () Arkusze („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 Z Sh For i = 0 To .Columns (Col). Znajdź ("*",,, , xlByColumns, xlPrevious) .Row ReDim Preserve ListeMots (j) ListeMots (j) = .Cells (i + 2, Col) j = j + 1 Następny koniec z MotsTraites = MotsTraites + UBound (ListeMots) End Sub 'Enlève de la li ste, 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 Jako Object, c lettresutilisees = Range ("grille") '-----> Menu Insertion / Noms / Définir Set MonDico1 = CreateObject ("Scripting.Dictionary") For Each c In lettresutilisees MonDico1 (c) = " "Następny c Ustaw MonDico2 = CreateObject (" Scripting.Dictionary ") Dla każdego c W alfabecie Jeśli nie MonDico1.Exists (c) Następnie MonDico2 (c) =" "Następny c lettresmanquantes = Application.Transpose (MonDico2.Keys) ListeMotsTemp = ListeMots Wymaż ListeMots Dla i = 0 Do UBound (ListeMotsTemp) mot = ListeMotsTemp (i) Dla j = 1 Do UBound (lettresmanquantes) lettr = lettresmanquantes (j, 1) Jeśli InStr (mot, lettr) = 0 Następnie test = True Else test = False Exit For End If Next j Jeśli test to 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 c, mot Dim rngTrouve As Range Dim i &, j &, NumLettre & Dim firstAddress, Flag As Boolean Dim MotsTouvesDansGrille (), k & Dim CellulesUtilisees Jako obiekt dla i = 1 do 4 Dla j = 1 To 4 kratka (i, j) = Komórki (i, j) Następny j Następny i Dla każdego motu W ListeMots Set rngTrouve = Zakres („kratka”). Cells.Find (Left (mot, 1)) If Not rngTrouve Is Nothing Then Erase T_Out Indic = 0 ReDim Preserve T_Out (Indic) T_Out (Indic) = rngTrouve.Address Set CellulesUtilisees = CreateObject ("Scripting.Dictionary") CellulesVoisines CellulesUtilisees, rngTrouve, mot, 1 firstAddress = rngTrouve.Address Do Set rngTrouve = rngTrouve.Address Do Set rngTrouve = Range (" grille "). Cells.FindNext (rngTrouve) Usuń T_Out Indic = 0 ReDim Preserve T_Out (Indic) T_Out (Indic) = rngTrouve.Address Set CellulesUtilisees = CreateObject (" Scripting.Dictionary ") CellulesVoisines CellulesUtilisees, rngTrouve, mot, 1 If Indic = Len (mot) - 1 Then Flag = True Dla Indic = LBound (T_Out) Do UBound (T_Out) Jeśli Range (T_Out (Indic)). Wartość Mid (mot, Indic + 1, 1) Then Flag = False: Exit For Next Indic Else Flag = False End Jeśli If Flag Exit Do Loop While Not rngTrouve Is Nothing i rngTrouve.Address End End If If Flag Then ReDim Preserve MotsTouvesDansGrille (k) MotsTouvesDansGrille (k) MotsTouvesDansGrille (k) = mot k = k + 1 End If Next mot Jeśli k 0 Następnie For k = LBound (MotsTouvesDansGrille) To UBound (MotsTouvesDansGrille) Sheets ("Feuil1"). Komórki (10 + k, NumCol + 1) = MotsTouvesDansGrille ( k) Następny k End If End Sub 'En fonction des cellules voisines Sub CellulesVoisines (ByRef Obj, CelInitiale, Strmot, niveau) Dim Cel As Range, Plage As Range, Flag As Boolean, c On Error Resume Następny zestaw Plage = Range (CelInitiale .Offset (-1, -1), CelInitiale.Offset (1, 1)) Obj.Add CelInitiale.Address, Mid (Strmot, niveau, 1) Dla każdego Cel In Plage Jeśli Indic + 1 = Len (Strmot) Następnie wyjdź For If Cel.Value = Mid (Strmot, niveau + 1, 1) Następnie Flag = True dla każdego c W Obj.Keys Jeśli c = Cel.Address Then Flag = False Next Jeśli Flag Then Obj.Add Cel.Address, Mid ( Strmot, niveau + 1, 1) Indic = Indic + 1 ReDim Preserve T_Out (Indic) T_Out (Indic) = Cel.Address CellulesVoisines Obj, Cel, Strmot, niveau + 1 Koniec jeśli Koniec Jeśli Next Cel End Sub Dodaj do standardowego modułu: W arkuszu kalkulacyjnym naciśnij ALT + F11 Wstaw / moduł.

Uwagi

Przede wszystkim zwróć szczególną uwagę na kolumny w Arkuszu2: Kolumna B (od B2 do BX: słowa 3-literowe), Kolumna C (od C2 do Cx: słowa 4-literowe), ....., Kolumna G (od G2 do Gx: 8-literowe słowa)