Excel / VBA - el juego Boggle

Las reglas del juego

Como se explica en Wikipedia ... // en.wikipedia.org/wiki/Boggle:

"El juego comienza agitando una bandeja cubierta de dieciséis dados cúbicos, cada uno con una letra diferente impresa en cada uno de sus lados. Los dados se asientan en una bandeja de 4x4 de modo que solo se ve la letra superior de cada cubo. Una vez que se han instalado En la parrilla, se inicia un cronómetro de arena de tres minutos y todos los jugadores comienzan simultáneamente la fase principal de juego.

Cada jugador busca palabras que se pueden construir a partir de las letras de los cubos secuencialmente adyacentes, donde los cubos "adyacentes" son los adyacentes horizontal, vertical y diagonalmente. Las palabras deben tener al menos tres letras de largo, pueden incluir singular y plural (u otras formas derivadas) por separado, pero no pueden usar el mismo cubo de letras más de una vez por palabra. Cada jugador registra todas las palabras que encuentra escribiendo en una hoja de papel privada. Después de que hayan transcurrido tres minutos, todos los jugadores deben dejar de escribir inmediatamente y el juego entra en la fase de puntuación ".

Prerrequisitos

En el libro de trabajo Boggle.xls, necesitas una cuadrícula para acomodar 16 letras. Para hacer esto, designaremos un rango de celdas 4X4, en el ejemplo D2: G5:

Insertar un nombre definido:

Menú: Inserción

Elección: Nom

Haga clic en: Définir

Nombres en el libro de trabajo => tipo: rejilla

Se refiere a => ingresar: Feuil1! $ D $ 2: $ G $ 5

Haga clic en Agregar.

Códigos VBA

 Opción Explicita 'Variables de dimensión «módulo» Dim ListeMots () As String Dim alphabet (25) Dim grille (1 To 4, 1 To 4) Dim T_Out () Dim Indic &, NumCol &, MotsTraites As Long' procédure principale servant d'appel aux autres procédures Sub Aleatoire_ProcedurePrincipale () Dim Wsh As Worksheet, NbreMotsTrouves As Long, i &, j &, cpt MotsTraites = 0 Set Wsh = ThisWorkbook.Worksheets ("Feuil2") Sheets ("Feuil1"). Range ("C10: H65") .Hojas de papel ("Feuil1"). Rango ("E7"). ClearContents cpt = 0 Para i = 1 a 4 Para j = 1 a 4 Si las celdas (i + 1, j + 3) "" Entonces cpt = cpt + 1 Next j Next i If cpt 16 Entonces MsgBox "Veillez à bien remplir la grille", vbCritical: Exit Sub For NumCol = 2 a 7 ListerMots Wsh, NumCol RetirerMotsLetttsPosques de macrosPersonas de los Estados Unidos de América. ) .Encuentre ("*",,,, xlByColumns, xlPrevious) .Row - 9) Hojas siguientes ("Feuil1"). Range ("E7") = "Nombre de mots trouvés:" & NbreMotsTrouves End Sub 'Tirage au sort des lettres, à commander depuis un bouton dans la feuille Sub Tirage () Dim i &, j &, numer, y For i = 0 a 25 alfabeto (i) = Chr (65 + i) Next For i = 1 To 4 For j = 1 To 4 Randomize numer = CInt (25 * Rnd) - 5 Si numer> 25 Luego numer = numer - numer + 10 If numer <0 Then numer = numer + 5 grille (i, j) = alphabet (numer) Next j Next i For i = 1 To 4 Para j = 1 a 4 celdas (i + 1, j + 3) = rejilla (i, j) Siguiente j Siguiente i Fin Sub 'Efface les lettres et les solutions, à commander depuis un bouton dans la feuille Sub Efface () Hojas ("Feuil1"). Range ("C10: H65536"). Hojas claras ("Feuil1"). Range ("E7"). ClearContents Sheets ("feuil1"). Range ("grille"). ClearContents End Sub ' Liste tous les mots (solutions) dans la feuille Feuil2 Sub ListerMots (Sh As Worksheet, ByVal Col As Integer) Dim i &, j & Erase ListeMots con Sh For i = 0 To .Columns (Col) .Find ("*",,, , xlByColumns, xlPrevious .Row ReDim Preserve ListeMots (j) ListeMots (j) = .Cells (i + 2, Col) j = j + 1 Next 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 String, lettr $, mot $ Dim i &, j &, k &, test As Boolean Dim MonD112 Object, MonDico2 As Object, c lettresutilisees = Range ("grille") '-----> Menu Insertion / Noms / Définir Set MonDico1 = CreateObject ("Scripting.Dictionary") Para cada c In lettresutilisees MonDico1 (c) = " "Next c Set MonDico2 = CreateObject (" Scripting.Dictionary ") para cada c En alfabeto Si no MonDico1.Exists (c) Entonces MonDico2 (c) =" "Next c lettresmanquantes = Application.Transpose (MonDico2.Keys) ListeMotsTemp = ListeMots Borrar ListeMots For i = 0 To UBound (ListeMotsTemp) mot = ListeMotsTemp (i) For j = 1 To UBound (lettresmanquantes) lettr = lettresmanquantes (j, 1) Si InStr (mot, lettr) = 0 Entonces prueba = True Else test = Falso Salir Para finalizar Si Siguiente j Si prueba Luego ReDim Conserve ListeMots (k) ListeMots (k) = ListeMotsTemp (i) k = k + 1 Fin Si es siguiente 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 For i = 1 To 4 For j = 1 To 4 rejilla (i, j) = Celdas (i, j) Siguiente j Siguiente i Para cada mot En ListeMots Set rngTrouve = Range ("grille"). Cells.Find (Izquierda (mot, 1)) Si no es rngTrouve no es nada entonces Erase T_Out Indic = 0 ReDim Preserve T_Out (Indic) T_Out (Indic) = rngTrouve.Address Set CellulesUtilisees = CreateObject ("Scripting.Dictionary") CellulesVoisines. grille "). Cells.FindNext (rngTrouve) Borrar T_Out Indic = 0 ReDim Preserve T_Out (Indic) T_Out (Indic) = rngTrouve.Address Set CellulesUtilisees = CreateObject (" Scripting.Dictionary ") CellulesVtilines CellulesUtilisees, rz = Len (mot) - 1 Entonces Indicador = Verdadero Para Indicador = LBound (T_Out) A UBound (T_Out) Si Rango (T_Out (Indic)). Valor Mid (mot), Indicador + 1, 1) Luego Indicador = Falso: Salir para el Siguiente Indicador Otro = Falso Finalizar Si Indicador luego Salir Hacer Loop Mientras no está en Rang La contraseña no es nada Y rngTrouve.Dirección primeroDirección Finalizar Si Sí Indicador Luego ReDim Preservar MotsTouvesDansGrille (k) MotsTouvesDansGrille (k) = mot k = k + 1 Fin Si Siguiente mot Si k 0 Entonces Para k = LBound (MotsTouvesDansGrille) To UBound (MotsTouvesDansGrille) Hojas ("Feuil1"). Células (10 + k, NumCol + 1) = MotsTouvesDansGrille ( k) Siguiente 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 En Error Reanudar Next Set Plage = Range (CelInitiale .Offset (-1, -1), CelInitiale.Offset (1, 1)) Obj.Add CelInitiale.Address, Mid (Strmot, niveau, 1) Para cada Cel In Plage Si Indic + 1 = Len (Strmot) y luego Exit For If Cel.Value = Mid (Strmot, niveau + 1, 1) Then Flag = True Para cada c En Obj.Keys If c = Cel.Address Entonces Flag = False Next Si Flag luego Obj.Add Cel.Address, Mid ( Strmot, niveau + 1, 1) Indic = Indic + 1 ReDim Preserve T_Out (Indic) T_Out (Indic) = Cel.Address CellulesVoisines Obj, Cel, Strmot, niveau + 1 End If End Si siguiente Cel End Sub Agregar a un módulo estándar: Desde su hoja de cálculo, presione ALT + F11 Insertar / Módulo.

Notas

Sobre todo, preste especial atención a las columnas en la Hoja 2: Columna B (de B2 a BX: palabras de 3 letras), Columna C (de C2 a Cx: palabras de 4 letras), ....., Columna G (de G2 a Gx: palabras de 8 letras)