Excel / VBA - เกมเกรงกลัว

กฎของเกม

ตามที่อธิบายไว้ใน Wikipedia ... // en.wikipedia.org/wiki/Boggle:

"เกมเริ่มต้นด้วยการเขย่าถาดที่ปกคลุมด้วยลูกเต๋าสิบหกลูกบาศก์โดยแต่ละตัวมีตัวอักษรต่างกันพิมพ์บนแต่ละด้านของมันลูกเต๋าตั้งอยู่ในถาด 4x4 เพื่อให้มองเห็นตัวอักษรบนสุดของแต่ละก้อนเท่านั้น ตารางตัวจับเวลาทรายสามนาทีเริ่มทำงานและผู้เล่นทุกคนพร้อมกันจะเริ่มเฟสหลักของการเล่นพร้อมกัน

ผู้เล่นแต่ละคนค้นหาคำที่สามารถสร้างขึ้นจากตัวอักษรของก้อนที่อยู่ติดกันตามลำดับโดยที่ "ติดกัน" ก้อนเป็นแนวนอนแนวตั้งหรือแนวทแยงมุมที่อยู่ใกล้เคียง คำต้องมีความยาวอย่างน้อยสามตัวอักษรอาจรวมเอกพจน์และพหูพจน์ (หรือรูปแบบอื่น ๆ ที่ได้รับ) แยกจากกัน แต่ไม่สามารถใช้คิวบ์ตัวอักษรเดียวกันมากกว่าหนึ่งครั้งต่อคำ ผู้เล่นแต่ละคนบันทึกคำทั้งหมดที่พบโดยเขียนลงบนกระดาษส่วนตัว หลังจากผ่านไปสามนาทีผู้เล่นทุกคนจะต้องหยุดเขียนทันทีและเกมจะเข้าสู่ขั้นตอนการให้คะแนน "

ข้อกำหนดเบื้องต้น

ในสมุดงาน Boggle.xls คุณต้องใช้กริดเพื่อรองรับตัวอักษร 16 ตัว ในการทำเช่นนี้เราจะกำหนดช่วง 4X4 เซลล์ในตัวอย่าง D2: G5:

ใส่ชื่อที่กำหนด:

เมนู: การแทรก

ตัวเลือก: Nom

คลิก: Définir

ชื่อในสมุดงาน => พิมพ์: ตะแกรง

หมายถึง => ป้อน: Feuil1! $ D $ 2: $ G $ 5

คลิกที่เพิ่ม

รหัส VBA

 ตัวเลือกที่ชัดเจน 'ตัวแปรขนาด«โมดูล» Dim ListeMots () เป็นตัวอักษร Dim Dim (25) กระจังหน้า Dim (1 ถึง 4, 1 ถึง 4) Dim T_Out () Dim Indic &, NumCol &, MotsTraites As Long' procédure mainale servant d'appel คำสั่งย่อยอัตโนมัติ Aleatoire_ProcedurePrincipale () Dim Wsh เป็นแผ่นงาน, NbreMotsTrouves ตราบใดที่ฉัน &, j &, cpt MotsTraites = 0 ตั้ง Wsh = ThisWorkbook.Worksheets ("Feuil2") ช่วง (C10: 655) .Clear Sheets ("Feuil1"). Range ("E7") ClearContents cpt = 0 สำหรับ i = 1 ถึง 4 สำหรับ j = 1 ถึง 4 หาก j (1 + 1, j + 3) "" จากนั้น cpt = cpt + 1 ถัดไป j ถัดไป i ถ้า cpt 16 จากนั้น MsgBox "Veillez à bien remplir la grille", vbCritical: Exit Sub สำหรับ NumCol = 2 ถึง 7 ListerMots Wsh, NumCol RetirerMotsLettresManquantes MotsDansGrille ) .Find ("*",,,,, xlByColumns, xlPrevious) .Row - 9) แผ่นถัดไป ("Feuil1"). ช่วง ("E7") = "Nombre de mots trouvés:" & NbreMotsTrouves การจัดเรียงย่อย ตามด้วย, ผู้บัญชาการà เลิกบูลและลาฟารูย Sub Tirage () Dim i &, j &, numer, y สำหรับ i = 0 ถึง 25 ตัวอักษร (i) = Chr (65 + i) ถัดไปสำหรับ i = 1 ถึง 4 สำหรับ j = 1 ถึง 4 สุ่มตัวเลข = CInt (25 * Rnd) - 5 ถ้า numer> 25 จากนั้น numer = numer - numer + 10 ถ้า numer <0 แล้ว numer = numer + 5 กระจังหน้า (i, j) = ตัวอักษร (numer) Next j Next i สำหรับ i = 1 ถึง 4 สำหรับ j = 1 ถึง 4 Cells (i + 1, j + 3) = กระจังหน้า (i, j) ถัดไป j ถัดไป i ถัดไป i สิ้นสุด Sub 'Efface และการแก้ไขปัญหา, ผู้บัญชาการสั่งยกเลิก bouton และ la feuille Sub Efface () แผ่นงาน ("Feuil1"). ช่วง ("C10: H65536"). ล้างแผ่น ("Feuil1"). ช่วง ("E7"). แผ่นงาน ClearContents ("feuil1"). ช่วง ("กระจัง") ClearContents End Sub ' ฟังไฟล์ mots (โซลูชั่น) และ la feuille Feuil2 Sub ListerMots (Sh As Worksheet, ByVal Col As Integer) Dim i &, & j & ลบ ListeMots ด้วย Sh สำหรับ i = 0 ถึง. คอลัมน์ (Col) .Find (")", , xlByColumns, xlPrevious) .Row ReDim สงวน ListeMots (j) ListeMots (j) =. เซลล์ (i + 2, Col) j = j + 1 ท้ายถัดไปด้วย MotsTraites = MotsTraites + UBound (ListeMots) การผลิต, และ mots contreant des lettres ne faisant pas partie du tirage Sub RetirerMotsLettresManquantes () ติ่มซำ lettresutilisees (), Dimtetmanquantes () Dim ListeMotsTemp () ในฐานะที่เป็นสตริง, ลอง $ และฉัน, j & k, เป็น & ทดสอบ, 1) Object, MonDico2 เป็น Object, c lettresutilisees = Range ("grille") '-----> การแทรกเมนู / Noms / Définirตั้ง MonDico1 = CreateObject ("Scripting.Dictionary") สำหรับแต่ละ c ใน lettresutilisees MonDico1 (c) = " "Next c Set MonDico2 = CreateObject (" Scripting.Dictionary ") สำหรับตัวอักษร c แต่ละตัวหากไม่ใช่ MonDico1.Exists (c) MonDico2 (c) จากนั้น =" "Next c lettresmanquantes = Application.Transpose (MonDico2.Keys) ListeMotsTemp = ListeMots ลบ ListeMots สำหรับ i = 0 ถึง UBound (ListeMotsTemp) mot = ListeMotsTemp (i) สำหรับ j = 1 ถึง UBound (lettresmanquantes) lettr = lettresmanquantes (j, 1) ถ้า InStr (mot, lettr) = 0 ออกจากเท็จสำหรับสิ้นสุดหากถัดไป j ถ้าทดสอบแล้ว ReDim รักษา ListeMots (k) ListeMots (k) = ListeMotsTemp (i) k = k + 1 สิ้นสุดถ้าถัดไป i สิ้นสุด Sub 'Proc ดูคำอธิบายเพิ่มเติม MotsDansGrille () Dim c, mot Dim rngTrouve เป็น Range Dim i &, j &, NumLettre & Dim firstAddress, ตั้งค่าสถานะเป็นบูลีน Dim MotsTouvesDansGrille (), k & Dim CellulesUtilisees เป็นวัตถุสำหรับ i = 1 ถึง 1 = 1 4 กระจัง (i, j) = เซลล์ (i, j) ถัดไป j ถัดไป i สำหรับแต่ละ mot ใน ListeMots Set rngTrouve = Range ("grille") Cells.Find (ซ้าย (mot, 1)) ถ้าไม่ใช่ rngTrouve ลบ T_Out Indic = 0 ReDim รักษา T_Out (Indic) T_Out (Indic) = rngTrouve.Address Set CellulesUtilisees = CreateObject ("Scripting.Dictionary") CellulesVoisines CellulesUtilisees, rngTrouve, rssTrouve.Retat (Set) Grille "). Cells.FindNext (rngTrouve) ลบ T_Out Indic = 0 ReDim รักษา T_Out (Indic) T_Out (Indic) = rngTrouve.Address Set CellulesUtilisees =" สร้างสคริปต์ "พจนานุกรม = Len (mot) - 1 จากนั้นตั้งค่า = True สำหรับ Indic = LBound (T_Out) ถึง UBound (T_Out) หาก Range (T_Out (Indic)) ค่า Mid (mot), +1 + 1, 1) จากนั้นตั้งค่าสถานะ = False: ออกเพื่อระบุสถานะอื่นต่อไป = จบสิ้นหากหากตั้งค่าสถานะแล้วออกจากลูปขณะที่ไม่ใช้ rngTrouve ไม่มีอะไรและ rngTrouve.Address ก่อนที่จะอยู่ถ้าหากตั้งค่าสถานะอีกครั้งรักษา MotsTouvesDansGrille (k) MotsTouvesDansGrille (k) = mot k = k + 1 สิ้นสุดถ้า mot ถัดไปถ้า k 0 สำหรับ k = LBound (MotsTouvesDansGrille) ไปยัง UBound (MotsTouvesDansGrille) แผ่น ("Feuil1") เซลล์ (10 + k, NumCol + 1) = MotsTouvesDansGrille k) Next k สิ้นสุดถ้า End Sub 'En Fonction des cellules voisines Sub CellulesVoisines (ByRef Obj, CelInitiale, Strmot, niveau) Dim Cel As Range, Plage As Range, ตั้งค่าสถานะเป็นบูลีน, C ในข้อผิดพลาด Resume Set Plage = Range (CelInitiale .Offset (-1, -1), CelInitiale.Offset (1, 1)) Obj.Add CelInitiale.Address, Mid (Strmot, niveau, 1) สำหรับแต่ละ Cel ใน Plage ถ้า Indic + 1 = Len (Strmot) จากนั้นออก สำหรับถ้า Cel.Value = Mid (Strmot, niveau + 1, 1) จากนั้นตั้งค่าสถานะ = True สำหรับแต่ละ c ใน Obj.Keys ถ้า c = Cel.Address แล้วตั้งค่าสถานะ = False ถัดไปหากตั้งค่าสถานะแล้ว Obj.Add Cel.Address, Mid ( Strmot, niveau + 1, 1) Indic = Indic + 1 ReDim รักษา T_Out (Indic) T_Out (Indic) = Cel.Address CellulesVoisines Obj, Cel, Strmot, niveau + 1 End หากสิ้นสุดถ้าถัดไป Cel End Sub เพิ่มไปยังโมดูลมาตรฐาน: จากสเปรดชีตของคุณกด ALT + F11 Insert / Module

หมายเหตุ

เหนือสิ่งอื่นใดให้ความสนใจเป็นพิเศษกับคอลัมน์ใน Sheet2: คอลัมน์ B (จาก B2 ถึง BX: คำ 3 ตัวอักษร), คอลัมน์ C (จาก C2 ถึง Cx: คำ 4 ตัวอักษร), ....., คอลัมน์ G (จาก G2 ถึง Gx: คำ 8 ตัวอักษร)