Excel / VBA - Boggle 게임

게임의 규칙

Wikipedia에서 설명한대로 ... // en.wikipedia.org/wiki/Boggle :

"이 게임은 16 개의 입방체 주사위로 된 쟁반을 뒤집어 쓴다. 각 주사위는 각면에 다른 문자가 인쇄되어있다. 주사위는 4x4 트레이에 고정되어 각 큐브의 첫 글자 만 볼 수있다. 그리드에 3 분짜리 모래 타이머가 시작되고 모든 플레이어가 동시에 게임의 기본 단계를 시작합니다.

각 플레이어는 연속적으로 인접한 큐브의 문자로 구성 할 수있는 단어를 검색합니다. 인접한 큐브는 가로, 세로 또는 대각선으로 인접한 큐브입니다. 단어는 최소 3 자 이상이어야하며 단수 및 복수 (또는 다른 파생 형식)를 따로 포함 할 수 있지만 단어 당 한 번 이상 동일한 문자 큐브를 사용할 수 없습니다. 각 플레이어는 자신이 찾은 모든 단어를 사적인 종이에 적어서 기록합니다. 3 분이 경과하면 모든 플레이어는 즉시 글쓰기를 멈추고 게임은 득점 단계에 들어갑니다. "

전제 조건

Boggle.xls 통합 문서에는 16자를 수용 할 수있는 표가 필요합니다. 이렇게하려면 D2 : G5 예에서 4X4 셀 범위를 지정합니다.

정의 된 이름 삽입 :

메뉴 : 삽입

선택 : 이름

클릭 : Définir

통합 문서 이름 => 유형 : 그릴

=> 다음을 입력하십시오 : Feuil1! $ D $ 2 : $ G $ 5

추가를 클릭하십시오.

VBA 코드

 Option Explicit 'Dimensions 변수«모듈»Dim ListeMots () As String 딤 알파벳 (25) Dim 그릴 (1에서 4, 1에서 4까지) Dim T_Out () Dim Indic &, NumCol & MotsTraites As Long' ( "Feuil2") 시트 ( "Feuil1") 범위 ( "C10 : H65536") Wats = ThisWorkbook.Worksheets ( "Feuil2") 시트 ( "Feuil2") 시트 ( "C10 : H65536") 워크 시트로 워크 시트가 흐리게 표시되면 워크 시트와 워크 시트가 흐리게 표시됩니다. ( "Feuil1") 범위 ( "E7") ClearContents cpt = 0 i = 1 ~ 4 For j = 1 ~ 4 세포가 (i + 1, j + 3) 인 경우 "cpt = cpt + 1 다음 j 다음 cpt 16 그렇다면 MsgBox "Veillez à bien remplir la grille", vbCritical : NumCol = 2에서 7로 리스터 모트 Wsh, NumCol RetirerMotsLettresManquantes MotsDansGrille 다음은 i = 3에서 8 NbreMotsTrouves = NbreMotsTrouves + (열 (i) ( "Feuil1") 범위 ( "E7") = "Nombre de mots trouvés :"& NbreMotsTrouves End Sub 'Tirage au sort ( "*",,, xlByColumns, xlPrevious) des lettres, à commander depuis (i) = Chr (65 + i) 다음은 i = 1 ~ 4는 j = 1 ~ 4는 숫자를 랜덤 화합니다 = CInt (25 * Rnd) - 5 숫자가 25보다 큰 경우 numer = numer - numer + 10 numer = 0이면 numer = numer + 5 grille (i, j) = 알파벳 (numer) 다음 j 다음 i i = 1 To 4 j = 1 ~ 4 셀 (i + 1, j + 3) = 그릴 (i, j) 다음 j 다음 End End 'Efface les lettres et les 솔루션, commander depuis unbouton dans la feuille Sub Efface 범위 ( "Feuil1") 범위 ( "C10 : H65536") Clear Sheets ( "Feuil1") 범위 ( "E7") ClearContents 시트 ( "feuil1") 범위 ( "그릴") ClearContents End Sub ' Listes tous les mots (솔루션) dans la feuille Feuil2 Sub ListerMots (워크 시트, ByVal Col As Integer) i = 0에 대해 Sh로 ListeMots 지우기 .Columns (Col) .Find ( "*",, , xlByColumns, xlPrevious) .Row ReDim 보존 ListeMots (j) ListeMots (j) = .Cells (i + 2, Col) j = j + 1 다음 끝 MotsTraites = MotsTraites + UBound (ListeMots) 끝내기 'Enlève de la li ($) $, $ $, $ & $, $ & $ & $ & $ & $ & $ & $ & $ & $ & $ & $ & $ & $ & $ & $ & $ & $ & $ & $ & 개체 삽입, MonDico2 개체로, C lettresutilisees = 범위 ( "그릴") '-----> 메뉴 삽입 / Noms / Définir 집합 MonDico1 = CreateObject ( "Scripting.Dictionary") For eachc lettresutilisees MonDico1 (c) = " "다음 c Set MonDico2 = CreateObject ("Scripting.Dictionary ") 각 c에 대해 알파벳 If Not MonDico1.Exists (c) 그런 다음 MonDico2 (c) =" "다음 c lettresmanquantes = Application.Transpose (MonDico2.Keys) ListeMotsTemp = ListeMots InStr (mot, lettr) = 0 그런 다음 test = True이면 Else test = i = 0이면 ListMots를 i = 0으로 Ubound (ListeMotsTemp)로 이동 = ListeMotsTemp (i) j = 1이면 Ubound (lettresmanquantes) lettr = lettresmanquantes (j, 1) (k) ListeMots (k) = ListeMotsTemp (i) k = k + 1 End If 다음 i End Sub 'Proc firstModDansGrille () Sub MotsDansGrille () Dim c, mot dim rngTrouve as 범위 Dim i, j 및 NumLettre & Dim firstAddress, 부울 값으로 플래그 Dim MotsTouvesDansGrille (), k 및 Dim CelluleUtilisees 객체로 i = 1 ~ 4 To j = 1 To 4 격자 (i, j) = 셀 (i, j) 다음 j 다음 i 각 ListeMots에 대해 rngTrouve = 범위 ( "그릴") Cells.Find (Left (mot, 1)) Not RngTrouve is Nothing T_Out (인도어) T_Out (인도어) = rngTrouve.Address Set CellulesUtilisees = CreateObject ( "Scripting.Dictionary") CellulesVoisines CellulesUtilisees, rngTrouve, mot, 1 firstAddress = rngTrouve.Address do Set rngTrouve = Range ( " 그릴 ") Cells.FindNext (rngTrouve) T_Out 지우기 Indic = 0 ReDim Preserve T_Out (Indic) T_Out (인도어) = rngTrouve.Address Set CellulesUtilisees = CreateObject ("Scripting.Dictionary ") CellulesVoisines CellulesUtilisees, rngTrouve, mot, 1 인도어 = Len (mot) - 1 그런 다음 플래그 = True이면 Indic = LBound (T_Out) UBound (T_Out)이면 Range (T_Out (인도)). Value Mid, Indic + 1, 1) 그런 다음 Flag = False : 다음 인도어로 끝내기 Else Flag = False End If If If If If RngTrouve is Nothing 그리고 rngTrouve.Address firstAddress End If If If ReDim Preserve MotsTouvesDansGrille (k) MotsTouvesDansGrille (10 + k, NumCol + 1) = MotsTouvesDansGrille (MotsTouvesDansGrille) 셀 (10 + k, NumCol + 1) 셀 (10 + k, NumCol + 1) k) 다음 k End If End Sub '셀의 음소거 (Cell) 셀의 음소표 (ByRef Obj, CelInitiale, Strmot, Niveau) 범위, Plage As 범위, 부울로 플래그, C On Error 다음 Set Plage = Range (CelInitiale .Offset (-1, -1), CelInitiale.Offset (1, 1)) Obj.Add CelInitiale.Address, Mid (Strmot, niveau, 1) 각 Cel In Plage에 대해 Indic + 1 = Len (Strmot) For If 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 Preserve T_Out (인도어) = Cel.Address CellulesVoisines Obj, Cel, Strmot, niveau + 1 End If End If 다음 Cel End Sub 표준 모듈에 추가 : 스프레드 시트에서 Alt + F11 Insert / Module (삽입 / 모듈).