Excel / VBA - لعبة Boggle

قواعد اللعبة

كما هو موضح في ويكيبيديا ... // en.wikipedia.org/wiki/Boggle:

"تبدأ اللعبة من خلال هز صينية مغطاة مكونة من ستة عشر مكعبًا من الزهر ، كل منها بحرف مختلف مطبوع على كل جانب من جوانبها. يستقر الزهر في صينية 4 × 4 بحيث يصبح الحرف العلوي فقط من كل مكعب ظاهرًا. بعد أن يستقروا في الشبكة ، يتم تشغيل مؤقت رمل مدته ثلاث دقائق ويبدأ جميع اللاعبين في نفس الوقت المرحلة الرئيسية من اللعب.

يبحث كل لاعب عن الكلمات التي يمكن إنشاؤها من خلال أحرف المكعبات المجاورة بالتسلسل ، حيث تكون المكعبات "المجاورة" هي تلك المجاورة أفقياً أو رأسياً أو قطرياً. يجب أن تتكون الكلمات من ثلاثة أحرف على الأقل ، وقد تشمل المفرد والجمع (أو الأشكال المشتقة الأخرى) بشكل منفصل ، ولكن قد لا تستخدم نفس مكعب الأحرف أكثر من مرة واحدة لكل كلمة. يسجل كل لاعب كل الكلمات التي يجدها أو هي بالكتابة على ورقة خاصة. بعد مرور ثلاث دقائق ، يجب على جميع اللاعبين التوقف فورًا عن الكتابة ودخول اللعبة مرحلة التسجيل ".

المتطلبات الأساسية

في مصنف Boggle.xls ، تحتاج إلى شبكة لاستيعاب 16 حرفًا. للقيام بذلك ، سنقوم بتعيين نطاق من الخلايا 4X4 ، في المثال D2: G5:

أدخل اسمًا محددًا:

القائمة: الإدراج

الاختيار:

انقر فوق: Définir

الأسماء في المصنف => النوع: مصبغة

يشير إلى => أدخل: Feuil1! $ D $ 2: $ G $ 5

انقر فوق "إضافة".

رموز VBA

 Option Explicit "متغيرات البعد" module »Dim ListeMots () باسم String Dim alphabet (25) Dim grille (1 إلى 4، 1 إلى 4) Dim T_Out () Dim Indic &، NumCol &، MotsTraites princip Long" procédure principale servic d'appel aux autres procédures Sub Aleatoire_ProcedurePrincipale () Dim Wsh As Workheet، NbreMotsTrouves As Long، i &، j &، cpt MotsTraites = 0 Set Wsh = ThisWorkbook.Worksheets ("Feuil2") Sheets ("Feuil2") HANG. .Clear Sheets ("Feuil1"). Range ("E7"). ClearContents cpt = 0 For i = 1 إلى 4 For j = 1 إلى 4 إذا كانت الخلايا (i + 1، j + 3) "" ثم cpt = cpt + 1 التالي j التالي i إذا cpt 16 ثم MsgBox "Veillez à bien remplir la grille"، vbCritical: Exit Sub For NumCol = 2 to 7 ListerMots Wsh، NumCol RetirerMotsLettresManquantes MotsDansGrille Next For i = 3 To 8 NbreMotsTrouves = ). Find ("*"،،، xlByColumns، xl سابقة) .Row - 9) الأوراق التالية ("Feuil1"). Range ("E7") = "Nombre de mots trouvés:" & NbreMotsTrouves End Sub 'Tirage au sort des lettres، à command depuis un bouton dans la feuille Sub Tirage () Dim i &، j &، numer، y For i = 0 to 25 alphabet (i) = Chr (65 + i) Next For i = 1 to 4 For j = 1 to 4 Randomize numer = CInt (25 * Rnd) - 5 إذا كان العدد> 25 ثم العدد = العدد - العدد + 10 إذا كان العدد <0 ثم العدد = عدد + 5 شبكة (الأبجدية ، العدد) الأبجدية (العدد) التالي j التالي i لـ i = 1 إلى 4 بالنسبة إلى j = 1 إلى 4 خلايا (i + 1، j + 3) = grille (i، j) التالي j التالي i End Sub 'Efface les lettres et les solutions، à command depuis un bouton dans la feuille Sub Efface () صفائح ("Feuil1"). المدى ("C10: H65536"). صفائح واضحة ("Feuil1"). المدى ("E7"). صفائح ClearContents ("feuil1"). المدى ("مصبغة"). ClearContents End Sub ' Liste tous les mots (solutions) dans la feuille Feuil2 Sub ListerMots (Sh As Workheet، ByVal Col As Integer) Dim i &، j & Erase ListeMots With Sh For i = 0 To .Columns (Col) .Find ("*"،،، ، xlByColumns ، xl سابقة) .Row ReDim الحفاظ على ListeMots (j) ListeMots (j) = .Cells (i + 2، Col) j = j + 1 End End With 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 List، dett $ $، mot $ Dim i &، j &، k & test كائن ، MonDico2 ككائن ، c lettresutilisees = Range ("grille") '-----> قائمة الإدراج / Noms / Définir Set MonDico1 = CreateObject ("Scripting.Dictionary") لكل c في lettresutilisees MonDico1 (c) = " "Next c Set MonDico2 = CreateObject (" Scripting.Dictionary ") لكل c في الأبجدية إن لم يكن MonDico1.Exists (c) ثم MonDico2 (c) =" "التالي 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 ، ثم test = True Else test = False Exit For End If Next j If test، 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 As Object لـ i = 1 إلى 4 لـ j = 1 To 4 مصبغة (i ، j) = خلايا (i ، j) التالي j التالي i لكل حركة في ListeMots Set rngTrouve = Range ("grille"). Cells.Find (Left (mot، 1)) If not rngTrouve Is Nothing Then مسح T_Out Indic = 0 ReDim الحفاظ على T_Out (Indic) T_Out (Indic) = rngTrouve.Address Set CellulesUtilisees = CreateObject ("Scripting.Dictionary") CellulesVoisines CellulesUtilisees، rngTrouve، mot، 1 firstAddress = rngTrouve grille "). Cells.FindNext (rngTrouve) مسح T_Out Indic = 0 ReDim الحفاظ على T_Out (Indic) T_Out (Indic) = rngTrouve.Address Set CellulesUtilisees = CreateObject (" Scripting.Dictionary ") CellulesVoisines CellulesUtilisees، rngTrouve = Len (mot) - 1 ثم ضع علامة = True لـ Indic = LBound (T_Out) إلى UBound (T_Out) إذا كان النطاق (T_Out (Indic)). القيمة Mid (mot ، Indic + 1، 1) ثم Flag = False: Exit For Next Indic Else Flag = False End If If Flag ثم Exit Do Loop بينما Not rngTrouve ليس شيئا و rngTrouve.Address firstAddress End If If Flag Then ReDim الحفاظ على MotsTouvesDansGrille (k) MotsTouvesDansGrille (k) = mot k = k + 1 End If Next mot If k 0 Then For k = LBound (MotsTouvesDansGrille) To UBound (MotsTouvesDansGrille) Sheets ("Feuil1"). خلايا (10 + k ، NumCol + 1) = MotsTouvesDansGrille ( k) Next 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 Next Set Plage = Range (CelInitiale .Offset (-1، -1)، CelInitiale.Offset (1، 1)) Obj.Add CelInitiale.Address، Mid (Strmot، niveau، 1) For Cel Cel Plage If Indic + 1 = Len (Strmot) For If Cel.Value = Mid (Strmot، niveau + 1، 1) ثم Flag = True لكل c في Obj.Keys If c = Cel.Address ثم Flag = False التالي If Flag Then Obj.Add Cel.Address، Mid ( سترموت ، نيفو + 1 ، 1) Indic = Indic + 1 ReDim Preserve T_Out (Indic) T_Out (Indic) = Cel.Address CellulesVoisines Obj، Cel، Strmot، niveau + 1 End If End If End Cel التالي Sub إضافة إلى وحدة نمطية قياسية: اضغط على ALT + F11 إدراج / الوحدة النمطية.

ملاحظات

قبل كل شيء ، انتبه بشكل خاص إلى الأعمدة في الورقة 2: العمود B (من B2 إلى BX: الكلمات المكونة من 3 أحرف) ، العمود C (من C2 إلى Cx: الكلمات المكونة من 4 أحرف) ، ..... ، العمود G (من G2 إلى Gx: كلمات ذات 8 أحرف)