Excel / VBA - гра Boggle

Правила гри

Як пояснюється у Вікіпедії ... // en.wikipedia.org/wiki/Boggle:

"Гра починається з погойдування критого лотка з шістнадцятьма кубічними кістками, кожна з різними літерами, надрукованими на кожній з його сторін. Кістки осідають у лоток 4х4 так, що видно лише верхня літера кожного куба. сітка, трихвилинний пісочний таймер, і всі гравці одночасно починають основну фазу гри.

Кожен гравець шукає слова, які можуть бути побудовані з літер послідовно сусідніх кубів, де "суміжні" куби є ті, які горизонтально, вертикально або діагонально сусідні. Слова повинні бути не менше трьох літер довжиною, можуть включати однину і множину (або інші похідні форми) окремо, але не можуть використовувати один і той же кубік букв більше одного разу на слово. Кожен гравець записує всі слова, які він або вона знаходить, написавши на приватному аркуші паперу. Після закінчення трьох хвилин всі гравці повинні негайно припинити писати і гра вступає у фазу оцінки. "

Передумови

У робочій книжці Boggle.xls потрібна сітка для розміщення 16 літер. Для цього будемо призначати діапазон 4X4 осередків у прикладі D2: G5:

Вставити визначене ім'я:

Меню: Вставка

Вибір: Ном

Натисніть: Définir

Імена в робочій книзі => тип: решітка

Відноситься до => enter: Feuil1! $ D $ 2: $ G $ 5

Натисніть Додати.

Коди VBA

 Опція Явний модуль "Змінні від розміру" »Dim ListeMots () Як рядок Див алфавіту (25) Темна решітка (1 до 4, 1 до 4) Dim T_Out () Dim Індивідуальний &, NumCol &, MotsTraites As Long 'procédure principale servant d'appel aux autres procédures Sub Aleatoire_ProcedurePrincipale () Dim Wsh Як робочий лист, NbreMotsTrouves As Long, i &, j &, cpt MotsTraites = 0 Встановити Wsh = ThisWorkbook.Worksheets ("Feuil2") Листи ("Feuil1"). Діапазон ("C10: H65536") Діапазон ("E7") ClearContents cpt = 0 Для i = 1 до 4 Для j = 1 до 4 Якщо клітинки (i + 1, j + 3) "" Тоді cpt = cpt + 1 Далі j Далі i Якщо cpt 16 Тоді MsgBox "Veillez à been remplir la grille", vbCritical: Вихід Sub Для NumCol = 2 до 7 ListerMots Wsh, NumCol RetirerMotsLettresManquantes MotsDansGrille Наступний для i = 3 до 8 NbreMotsTrouves = NbreMotsTrouves + (Стовпці (i (), (), (), (), (), (), (5) Наступний аркуш ("Feuil1"). Діапазон ("E7") = "Номери словника:" & NbreMotsTrouves End Sub " des lettres, à commander depuis un bouton dans la feuille Sub Tirage () Дим i &, j &, число, y Для i = 0 до 25 алфавіту (i) = Chr (65 + i) Далі Для i = 1 до 4 Для j = 1 до 4 Вибрати число = CInt (25 * Rnd) - 5 Якщо число> 25 Тоді число = число - число + 10 Якщо число <0 Тоді число = число + 5 решітка (i, j) = алфавіт (число) Далі j Далі i Для i = 1 До 4 Для j = 1 до 4 осередків (i + 1, j + 3) = решітка (i, j) Далі j Далі i Закінчити підпрограму "Вибрати ліцензії та рішення", "Командир розблокувати" Аркуші ("Feuil1") Діапазон ("C10: H65536") Очистити аркуші ("Feuil1"). Діапазон ("E7") Листи ClearContents ("feuil1"). Діапазон ("grille"). ClearContents End Sub ' Список рішень (рішень) у форматі Feuil2 Sub ListerMots (Sh як робочий аркуш, ByVal Col As Integer) Dim i &, j & Видалення ListeMots з Sh для i = 0 To. Columns (Col) .Find ("*",,, , xlByColumns, xlPrevious) .Row ReDim Збереження ListeMots (j) ListeMots (j) = .Знаки (i + 2, Col) j = j + 1 Наступний кінець з MotsTraites = MotsTraites + UBound (ListeMots) Кінець Sub 'Enlève de la li (),,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, . Object, MonDico2 As Object, c lettresutilisees = Діапазон ("grille") '-----> Меню Вставка / Номи / Définir Встановити MonDico1 = CreateObject ("Scripting.Dictionary") Для кожного c In lettresutilisees MonDico1 (c) = " "Далі c Встановити MonDico2 = CreateObject (" Scripting.Dictionary ") Для кожного c алфавіту Якщо не MonDico1.Exists (c) Тоді MonDico2 (c) =" "Далі c lettresmanquantes = Application.Transpose (MonDico2.Keys) ListeMotsTemp = ListeMots Erase ListeMots For i = 0 До UBound (ListeMotsTemp) mot = ListeMotsTemp (i) Для j = 1 До UBound (lettresmanquantes) lettr = lettresmanquantes (j, 1) Якщо InStr (mot, lettr) = 0, тест = True Else test = False Вихід для End Якщо Next j Якщо тест Тоді ReDim Зберегти ListeMots (k) ListeMots (k) = ListeMotsTemp (i) k = k + 1 Кінець, якщо Next i End Sub 'Proc dur de recherche des mots Sub MotsDansGrille () Dim c, mot Дим rngTrouve Як діапазон Dim i &, j &, NumLettre & Dim firstAddress, Позначити як логічне Dim MotsTouvesDansGrille (), k & Dim CellulesВикористовувати як об'єкт для i = 1 до 4 Для j = 1 4 grille (i, j) = осередки (i, j) Наступний j Далі i Для кожного мота у ListeMots Встановити rngTrouve = Діапазон ("решітка"). Cells.Find (Left (mot, 1)) Якщо не rngTrouve ніщо Erase T_Out Indic = 0 ReDim збереження T_Out (індикатор) T_Out (Індика) = rngTrouve.Address Встановити CellulesUtilisees = CreateObject ("Scripting.Dictionary") CellulesVoisines CellulesUtilisees, rngTrouve. Cells.FindNext (rngTrouve) Стерти T_Out Індикатор = 0 ReDim Зберегти T_Out (індикатор) T_Out (Індика) = rngTrouve.Address Set CellulesUtilisees = CreateObject ("Scripting.Dictionary") CellulesVoisines CellulesUtilisees, rngTrouve, mot, 1 Якщо індикатор = Len (mot) - 1 Тоді Flag = True Для індексу = LBound (T_Out) Для UBound (T_Out) Якщо діапазон (T_Out (індикатор))., Індика + 1, 1) Тоді Flag = False: Вихід для наступного Індійський Ще інший Прапор = Помилковий кінець Якщо Якщо Позначити, то Вийти Зробити Петлю Хоча Не rngTrouve Нічого І rngTrouve.Address firstAddress Кінець Якщо Якщо Позначити Тоді ReDim Зберегти MotsTouvesDansGrille (k) MotsTouvesDansGrille (k) = mot k = k + 1 End If Next mot If k 0 Тоді для k = LBound (MotsTouvesDansGrille) Для UBound (MotsTouvesDansGrille) Листи ("Feuil1"). Клітини (10 + k, NumCol + 1) = MotsTouvesDansGrille ( k) Далі k Кінець, якщо закінчується Sub 'En fonction des cellules voisines Sub CellulesVoisines (відRef Obj, CelInitiale, Strmot, niveau) Затухати як діапазон, plage як діапазон, позначити як логічний, c у помилку відновити наступний набір Plage = діапазон (CelInitiale .Offset (-1, -1), CelInitiale.Offset (1, 1)) Obj.Add CelInitiale.Address, Mid (Strmot, niveau, 1) Для кожного Cel In Plage Якщо індикатор + 1 = Len (Strmot), то вийдіть Для Якщо Cel.Value = Mid (Strmot, niveau + 1, 1) Тоді Flag = True для кожного c У Obj.Keys Якщо c = Cel.Address Потім Flag = False Next Якщо Позначити Тоді Obj.Add Cel.Address, Середній ( Strmot, niveau + 1, 1) Indic = Індійський + 1 ReDim Збереження T_Out (індикатор) T_Out (Індика) = Cel.Address CellulesVoisines Obj, Cel, Strmot, niveau + 1 Кінець, якщо закінчиться, якщо наступний CEL Закінчити Підблокувати до стандартного модуля: З електронної таблиці натисніть ALT + F11 Вставка / модуль.

Примітки

Перш за все, зверніть особливу увагу на стовпці у Листі2: стовпець B (від B2 до BX: слова з трьох букв), стовпець C (від C2 до Cx: слова з 4 букв), ....., стовпець G (з G2) до Gx: 8-буквені слова)