Excel / VBA - permainan Boggle

Peraturan permainan

Seperti yang dijelaskan di Wikipedia ... // en.wikipedia.org/wiki/Boggle:

"Permainan bermula dengan menggoncang dulang yang ditutupi enam belas kubik padat, masing-masing dengan huruf yang berbeza dicetak pada setiap sisinya. Dadu itu akan menjadi dulang 4x4 sehingga hanya huruf atas setiap kubus yang dapat dilihat. grid, pemasa pasir selama tiga minit bermula dan semua pemain pada masa yang sama memulakan fasa utama permainan.

Setiap pemain mencari kata-kata yang boleh dibina dari huruf-huruf kiub bersebelahan, di mana kiub "bersebelahan" adalah orang-orang jiran secara mendatar, menegak atau menyerong. Perkataan mestilah sekurang-kurangnya tiga huruf panjang, mungkin termasuk bentuk tunggal dan jamak (atau bentuk asal lain) secara berasingan, tetapi tidak boleh menggunakan huruf huruf yang sama lebih dari sekali setiap kata. Setiap pemain merekodkan semua perkataan yang dia dapati dengan menulis pada kertas peribadi. Selepas tiga minit berlalu, semua pemain mesti berhenti menulis dengan segera dan permainan memasuki fasa pemarkahan. "

Prasyarat

Dalam buku kerja Boggle.xls, anda memerlukan grid untuk menampung 16 huruf. Untuk melakukan ini, kami akan melantik pelbagai sel 4X4, dalam contoh D2: G5:

Masukkan nama yang ditentukan:

Menu: Kemasukan

Pilihan: Nom

Klik: Définir

Nama di buku kerja => taip: gril

Merujuk kepada => masukkan: Feuil1! $ D $ 2: $ G $ 5

Klik Tambah.

Kod VBA

 Opsyen Eksplisit 'Dimensi modul de dimensi' Dim ListeMots () Sebagai abjad Dimensi String (25) Dim grille (1 hingga 4, 1 hingga 4) Dim T_Out () Dim Indic &, NumCol &, MotsTraites Sebagai 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" Jelas 1 (4) j = 1 hingga 4 Jika Sel (i + 1, j + 3) "" Kemudian cpt = cpt + 1 Next j Kemudian i Jika cpt 16 Kemudian MsgBox "Veillez à bien remplir la grille", vbCritical: Keluar Sub untuk NumCol = 2 hingga 7 ListerMots Wsh, NumCol RetirerMotsLettresManquantes MotsDansGrille Next Untuk i = 3 hingga 8 NbreMotsTrouves = NbreMotsTrouves + (Kolum (i ) .Find ("*",,, xlByColumns, xlPrevious) .Row - 9) Helaian Seterusnya ("Feuil1") Julat ("E7") = "Nombre de mots trouvés:" & NbreMotsTrouves End Sub ' des lettres, à depuis komander (1) Untuk i = 1 hingga 4 Untuk j = 1 ke 4 Rawak angka = CInt (25 * Rnd) - 5 Jika numer> 25 Kemudian numer = numer - numer + 10 Jika numer <0 Kemudian numer = numer + 5 gril (i, j) = abjad (numer) 4 Untuk j = 1 hingga 4 Sel (i + 1, j + 3) = gril (i, j) Seterusnya j Seterusnya i Akhir Sub 'Efface les lettres et les solutions, Lembaran ("Feuil1") Julat ("Feuil1") Julat ("C10: H65536"). Senarai kandungan (penyelesaian) dan feuille Feuil2 Sub ListerMots (Sh As Lembaran Kerja, ByVal Col As Integer) Dim i &, j & Hapus ListeMots Dengan Sh Untuk i = 0 Kepada .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 li (0) Dim ListeMotsTemp () Sebagai String, lettr $, mot $ Dim i &, j &, k &, test Sebagai 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) = " "Selanjutnya c Tetapkan MonDico2 = CreateObject (" Scripting.Dictionary ") Untuk Setiap c Dalam abjad Jika Tidak MonDico1.Exists (c) Kemudian MonDico2 (c) =" "Selanjutnya c lettresmanquantes = Application.Transpose (MonDico2.Keys) ListeMotsTemp = ListeMots Hapus listeMots Untuk i = 0 Untuk UBound (ListeMotsTemp) mot = ListeMotsTemp (i) Untuk j = 1 Untuk UBound (lettresmanquantes) lettr = lettresmanquantes (j, 1) Jika InStr (mot, lettr) Keluar dari Palsu Untuk Menamatkan Jika Seterusnya j Jika Ujicoba Kemudian Memulihkan Senarai ListeMots (k) ListeMots (k) = ListeMotsTemp (i) k = k + 1 Akhir Jika Seterusnya dan Akhir Sub Proc dure de recherche des mots Sub MotsDansGrille () Dim c, mot Dim Dimensi As Range Dim i &, j &, NumLettre & Dim firstAddress, Bendera Sebagai Boolean Dim MotsTouvesDansGrille (), k & Dim CellulesUtilisees As Object For i = 1 To 4 For j = 1 To 4 gril (i, j) = Sel (i, j) Seterusnya j Seterusnya i Untuk Setiap mot Dalam Senarai ListeMots rngTrouve = Julat ("gril") Sels.Find (Kiri (mot, 1)) Jika Tidak rngTrouve Tidak Ada Lalu Hapuskan T_Out Indic = 0 ReDim Memelihara T_Out (Indic) T_Out (Indic) = rngTrouve.Address Set CellulesUtilisees = CreateObject ("Scripting.Dictionary") CellulesVoisines CellulesUtilisees, rngTrouve.Address Do Set rngTrouve = gril "). Cells.FindNext (rngTrouve) Padam T_Out Indic = 0 Memelihara ReDim T_Out (Indic) T_Out (Indic) = rngTrouve.Address Set CellulesUtilisees = CreateObject (" Scripting.Dictionary ") CellulesVoisines CellulesUtilisees, rngTrouve, mot, = Len (mot) - 1 Kemudian Bendera = Benar Untuk Indic = LBound (T_Out) Ke UBound (T_Out) Jika Range (T_Out (Indic))., Indic + 1, 1) Kemudian Bendera = Palsu: Keluar Untuk Selanjutnya Indik Else Flag = Akhir Palsu Jika Jika Bendera Kemudian Keluar Do Loop Walaupun Tidak rngTrouve Tidak Ada Dan rngTrouve.Address firstAddress End Jika If Flag Then ReDim Preserve MotsTouvesDansGrille (k) MotsTouvesDansGrille (k) = mot k = k + 1 Tamat Jika Seterusnya mot Jika k 0 Kemudian Untuk k = LBound (MotsTouvesDansGrille) Kepada UBound (MotsTouvesDansGrille) Helaian ("Feuil1"). k) Selanjutnya k Akhir Jika Akhir Sub 'En fonction des cellules voisines Sub CellulesVoisines (ByRef Obj, CelInitiale, Strmot, niveau) Dim Cel As Range, Plage As Range, Bendera Sebagai Boolean, c Pada Ralat Ralat Seterusnya Set Plage = Range (CelInitiale (1, -1), CelInitiale.Offset (1, 1)) Obj.Add CelInitiale.Address, Mid (Strmot, niveau, 1) Untuk Setiap Cel Dalam Plage Jika Indic + 1 = Len (Strmot) Untuk Jika Cel.Value = Mid (Strmot, niveau + 1, 1) Kemudian Bendera = Benar Untuk Setiap c Di Obj.Keys Jika c = Cel.Address Kemudian Bendera = Palsu Kemudian Jika Bendera Kemudian Obj.Add Cel.Address, Mid Strmot, niveau + 1, 1) Indic = Indic + 1 Memelihara ReDim T_Out (Indic) T_Out (Indic) = Cel.Address CellulesVoisines Obj, Cel, Strmot, niveau + 1 Akhir Jika Akhir Jika Sub Akhir Cel End Sub Tambah ke modul standard: F11 Masukkan / Modul.

Nota

Di atas semua, beri perhatian khusus kepada lajur dalam Helaian2: Kolum B (dari B2 hingga BX: 3 huruf perkataan), Kolum C (dari C2 hingga Cx: huruf 4 huruf), ....., Ruangan G (dari G2 kepada Gx: perkataan 8 huruf)