एक्सेल / वीबीए - बोगल गेम

खेल के नियम

जैसा कि विकिपीडिया पर समझाया गया है ... // en.wikipedia.org/wiki/Boggle:

"खेल सोलह क्यूबिक पासा की एक कवर ट्रे को हिलाकर शुरू होता है, प्रत्येक को इसके प्रत्येक पक्ष पर मुद्रित एक अलग पत्र के साथ। पासा एक 4x4 ट्रे में बस जाता है ताकि प्रत्येक घन का केवल शीर्ष अक्षर दिखाई दे। बाद में वे बस गए। ग्रिड, तीन मिनट का रेत टाइमर शुरू किया गया है और सभी खिलाड़ी एक साथ खेल का मुख्य चरण शुरू करते हैं।

प्रत्येक खिलाड़ी शब्दों के लिए खोज करता है जो क्रमिक रूप से आसन्न क्यूब्स के अक्षरों से बनाया जा सकता है, जहां "आसन्न" क्यूब्स उन क्षैतिज, लंबवत या तिरछे पड़ोसी हैं। शब्दों में कम से कम तीन अक्षर लंबे होने चाहिए, इसमें एकवचन और बहुवचन (या अन्य व्युत्पन्न रूप) अलग से शामिल हो सकते हैं, लेकिन एक ही अक्षर क्यूब का उपयोग प्रति शब्द एक से अधिक बार नहीं किया जा सकता है। प्रत्येक खिलाड़ी वह सभी शब्द रिकॉर्ड करता है जो वह कागज की एक निजी शीट पर लिखकर पाता है। तीन मिनट बीत जाने के बाद, सभी खिलाड़ियों को तुरंत लिखना बंद कर देना चाहिए और खेल स्कोरिंग चरण में प्रवेश करता है। "

आवश्यक शर्तें

बोगल.एक्सएल वर्कबुक में, आपको 16 अक्षरों को समायोजित करने के लिए ग्रिड की आवश्यकता होती है। ऐसा करने के लिए, हम D2: G5 उदाहरण में, 4X4 कोशिकाओं की एक श्रृंखला नियुक्त करेंगे:

एक परिभाषित नाम डालें:

मेनू: प्रविष्टि

विकल्प: नाम

क्लिक करें: Définir

कार्यपुस्तिका में नाम => प्रकार: जंगला

रेफर्स = = दर्ज करें: Feuil1! $ D $ 2: $ G $ 5

Add पर क्लिक करें।

VBA कोड

 विकल्प स्पष्ट 'वेरिएबल्स डी आयाम «मॉड्यूल» मंद सूचीपत्र () स्ट्रिंग डिम वर्णमाला के रूप में (25) डिम जंगला (1 से 4, 1 से 4) डिम T_Out () डिम इंडिक और न्यूमकोल, MotsTraites लंबे समय तक' प्रिंसिपल सेवक नौकर डीप्पल। ऑक्स ऑटो रिक्वेस्ट सब एलिएटायर_प्रोसेरडिप्रिनल () डिम वश एज़ वर्कशीट, नब्रेमैट्सट्रूव्स लॉन्ग, आई, जे, जेपीटी, केट मॉटट्राइट्स = 0 सेट डब्ल्यूईटी = ThisWorkbook.Worksheets ("Feuil2") शीट्स ("Feuil1" रेंज ")"। .Clear शीट्स ("Feuil1")। श्रेणी ("E7")। ClearContents cpt = 0 for i = 1 To 4 for j = 1 To 4 यदि Cells (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 RetoterMotsLettresManquantes MotsDansGrille अगला i = 3 से लेकर 8 मिनट तक के लिए ) .Find ("*",,, xlByColumns, xlPrepret) .Row - 9) नेक्स्ट शीट्स ("Feuil1")। रेंज ("E7") = "नोमेब डे डॉट्स ट्रोवेस:" & NbreMotsTrouves End Sub 'Tirage au sort au। des lettres, à कमांडर depuis un bouton dans la feuille Sub Tirage () Dim i &, j &, numer, y for i = 0 to 25 वर्णमाला (i) = Chr (65 + i) आगे I के लिए = 1 से 4 के लिए j = 1 से 4 यादृच्छिक संख्या में = CInt (25 * Rnd) - 5 यदि अंक> 25 तो अंक = संख्या - संख्या + 10 यदि अंक <0 फिर संख्या = संख्यात्मक + 5 जंगला (i, j) = वर्णमाला (अंक) अगला j अगला भाग I = 1 के लिए 4 के लिए j = 1 से 4 सेल (i + 1, j + 3) = जंगला (i, j) अगला j अगला अगला सब एंड इफैस लेस लेट्रेस एट लेस सॉल्यूशंस, एक कमांडर डिपो यू एन बीटन डांस ला फुएर सब प्रयास () शीट्स ("Feuil1")। रेंज ("C10: H65536")। स्पष्ट शीट्स ("Feuil1")। रेंज ("E7")। ClearContents शीट्स ("feuil1")। रेंज ("grille")। ClearContents End Sub ' लिस् टॉस लेस मॉट्स (सॉल्यूशंस) डान्स ला फ्युइले फेउइल 2 सब लिस्टरमॉट्स (श एज़ वर्कशीट, बायवाल कर्नल एज़ एंगर के रूप में) डिम एंड आई, जे एंड इरेज़ लिस्टेमैट्स विद श फॉर आई = 0 टू। कोलीमन्स (कर्नल) एफइंड ("*" "),, ।, xlByColumns, xlPreprise) .Row ReDim संरक्षित लिस्टमोट्स (j) ListeMots (j) = .Cells (i + 2, Col) j = j + 1 MotsTraites = MotsTraites + UBound (ListeMots) के अंतिम उप 'Enlève deve de la) Ste, les mots contenant des lettres ne faisant pas partie du tirage Sub RetirerMotsLettresManquantes () Dim lettresutilisees (), lettresmanquantes () Dim ListeMotsTemp () As String, lettr $, mot $ $, mot $। Object, MonDico2 As Object, c lettresutilisees = Range ("grille") '-----> मेनू प्रविष्टि / Noms / Définir सेट MonDico1 = CreateObject ("Scripting। सहानुभूति) प्रत्येक c के लिए lettresutilisees MonDico1 (c) =" = " "अगला सी सेट MonDico2 = CreateObject (" Scripting.Dictionary ") प्रत्येक c के लिए वर्णमाला में यदि MonDico1.Exists नहीं है (c) तो MonDico2 (c) =" "अगला c lettresmantantes = Application.Transpose (MonDico2.Keys) ListeMotsTemp = ListeMots IBe के लिए मिटाएँ ListeMots i = 0 के लिए UBound (ListeMotsTemp) mot = ListeMotsTemp (i) for j = 1 To UBound (लेट्रेसमैनक्वांट्स) lettr = lettresmanquantes (j, 1) यदि InStr (उद्देश्य, lettr) = 0 तो परीक्षण का सही परीक्षण अंत के लिए गलत निकास यदि अगला j है तो परीक्षण करें तो फिर से देखें ListeMots (k) ListeMots (k) = ListeMotsTemp (i) k = k + 1 अंत यदि अगला I अंत उप 'प्रोक संरक्षित करें dure de recherche des mots Sub MotsDansGrille () Dim c, mot Dim rngTrouve As Range Dim i &, j &, NumLettre & Dim firstAddress, ध्वज के रूप में बूलियन Dim DotsTouvesDansGrille (), k & Dim CellulesUtilisees I श्रेणी के लिए 1 से 4 वर्ष के लिए। 4 जंगला (i, j) = कक्ष (i, j) अगला j अगला प्रत्येक सूची के लिए अगले में ListeMots सेट rngTrouve = Range ("grille")। Cells.Find (Left (mot, 1)) यदि rngTrouve है तो कुछ भी नहीं है। मिटाएँ T_Out Indic = 0 ReDim संरक्षित करें T_Out (Indic) T_Out (Indic) = rngTrouve.Address सेट CellulesUtilisees = CreateObject ("Scripting। सहारण") CellulesVoisines CellulesUtilisees, rngTrouve, mot, 1dd .dd 1, 1dd। grille ")। कोशिकाएं। FindNext (rngTrouve) मिटाएँ T_Out Indic = 0 ReDim Preserve T_Out (Indic) T_Out (Indic) = rngTrouve.Asress सेट करें CellUUtilisees = CreateObject (" Scripting.life ") सेलसिपोइज़ोयूप्स सेल्यूकोविस सेलसोईस सेल = लेन (मोट) - 1 फिर झंडा = इंडिक के लिए सच = यूबाउंड (टी_ऑट) को यूबाउंड (टी_ऑट) अगर रेंज (टी_ओट (इंडिक))। वैल्यू मिड (उद्देश्य), इंडिक + 1, 1) फिर फ्लैग = फाल्स: एग्जिट फॉर नेक्स्ट इंडिक एल्स फ्लैग = फाल्स एंड अगर फ्लैग एंड इफ अगर फ्लैग तो एग्जिट लूप जबकि नॉट रिगट्रेव कुछ भी नहीं है और फिर से प्रिंट करें। पहले एग््रेस्रेस एंड को फॉलो करें अगर फ्लैग को फिर से प्रिंट करें MotsTouvesDansGrille (k) (k) = mot k = k + 1 अंत यदि अगला उद्देश्य यदि k 0 है तो k = LBound (MotsTouvesDansGrille) के लिए UBound (MotsTouvesDansGrille) शीट्स ("Feilil1") कक्ष। (10 + k, NumCol + 1) = MotsTouvesDansGrille। के) नेक्स्ट के एंड एंड अगर एंड सब 'एन फोंशन डेस सेल्यूलस वॉयस सब सेल्यूल्सविओइन (बायरफ ओबज, सेलेनिअटेरी, स्ट्रॉमोट, निवेउ) डिम सेल अस रेंज, प्लेज अस रेंज, फ्लैग बुलियन, सी ऑन एरर रिज्यूमे नेक्स्ट सेट प्लेज = रेंज (सेलइन्सेन्ट्री) .Offset (-1, -1), CelInitiale.Offset (1, 1)) Obj.Add CelInitiale.Address, Mid (Strmot, niveau, 1) प्लेज में प्रत्येक सेल के लिए यदि Indic / 1 = Len (Strmot) तब बाहर निकलें If Cel.Value = Mid (Strmot, niveau + 1, 1) उसके बाद झंडा = Obj में प्रत्येक c के लिए सही। Keys if c = Cel.Address फिर ध्वज = गलत अगला ध्वज यदि झंडा तब Obj.Address.Address, Mid ( स्ट्रॉमोट, निवेउ + 1, 1) Indic = Indic + 1 ReDim संरक्षित करें T_Out (इंडिक) T_Out (इंडिक) = Cel.Address CellulesVoisines Obj, Cel, Strmot, niveau + 1 अंत यदि अगला अगला सिरा अंत उप मानक मॉड्यूल में जोड़ें: अपनी स्प्रैडशीट से, ALT + दबाएँ F11 डालें / मॉड्यूल।

इन सबसे ऊपर, Sheet2 में कॉलम पर विशेष ध्यान दें: कॉलम B (B2 से BX: 3-अक्षर शब्द), कॉलम C (C2 से Cx: 4-अक्षर शब्द), ....., कॉलम G (G2 से) को Gx: 8-अक्षर शब्द)