Excel/VBA - the Boggle game

The rules of the game

As explained on Wikipedia...https://enikipediarg/wiki/Boggle:

"The game begins by shaking a covered tray of sixteen cubic dice, each with a different letter printed on each of its sides. The dice settle into a 4x4 tray so that only the top letter of each cube is visible. After they have settled into the grid, a three-minute sand timer is started and all players simultaneously begin the main phase of play.

Each player searches for words that can be constructed from the letters of sequentially adjacent cubes, where "adjacent" cubes are those horizontally, vertically or diagonally neighboring. Words must be at least three letters long, may include singular and plural (or other derived forms) separately, but may not use the same letter cube more than once per word. Each player records all the words he or she finds by writing on a private sheet of paper. After three minutes have elapsed, all players must immediately stop writing and the game enters the scoring phase."

Prerequisites

In the Boggle.xls workbook, you need a grid to accommodate 16 letters. To do this, we will appoint a range of 4X4 cells, in the D2:G5 example:

Insert a defined name:

Menu: Insertion

Choice: Nom

Click: Définir

Names in workbook => type: grille

Refers to => enter: Feuil1!$D$2:$G$5

Click on Add.

VBA codes

Option Explicit 'Variables de dimension « module » 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:H65536").Clear Sheets("Feuil1").Range("E7").ClearContents cpt = 0 For i = 1 To 4 For j = 1 To 4 If Cells(i + 1, j + 3) <> "" Then cpt = cpt + 1 Next j Next i If cpt <> 16 Then 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 = NbreMotsTrouves + (Columns(i).Find("*", , , , xlByColumns, xlPrevious).Row - 9) Next Sheets("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 To 25 alphabet(i) = Chr(65 + i) Next For i = 1 To 4 For j = 1 To 4 Randomize numer = CInt(25 * Rnd) - 5 If numer > 25 Then 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 For j = 1 To 4 Cells(i + 1, j + 3) = grille(i, j) Next j Next i End Sub 'Efface les lettres et les solutions, à commander depuis un bouton dans la feuille Sub Efface() Sheets("Feuil1").Range("C10:H65536").Clear Sheets("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 With 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 liste, 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 MonDico1 As Object, MonDico2 As Object, c lettresutilisees = Range("grille") '-----> Menu Insertion/Noms/Définir Set MonDico1 = CreateObject("Scripting.Dictionary") For Each c In lettresutilisees MonDico1(c) = "" Next c Set MonDico2 = CreateObject("Scripting.Dictionary") For Each c In alphabet If Not MonDico1.Exists(c) Then MonDico2(c) = "" Next c lettresmanquantes = Application.Transpose(MonDico2.Keys) ListeMotsTemp = ListeMots Erase ListeMots For i = 0 To UBound(ListeMotsTemp) mot = ListeMotsTemp(i) For j = 1 To UBound(lettresmanquantes) lettr = lettresmanquantes(j, 1) If InStr(mot, lettr) = 0 Then test = True Else test = False Exit For End If Next j If test Then 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 For i = 1 To 4 For j = 1 To 4 grille(i, j) = Cells(i, j) Next j Next i For Each mot In ListeMots Set rngTrouve = Range("grille").Cells.Find(Left(mot, 1)) If Not rngTrouve Is Nothing Then Erase T_Out Indic = 0 ReDim Preserve T_Out(Indic) T_Out(Indic) = rngTrouve.Address Set CellulesUtilisees = CreateObject("Scripting.Dictionary") CellulesVoisines CellulesUtilisees, rngTrouve, mot, 1 firstAddress = rngTrouve.Address Do Set rngTrouve = Range("grille").Cells.FindNext(rngTrouve) Erase T_Out Indic = 0 ReDim Preserve T_Out(Indic) T_Out(Indic) = rngTrouve.Address Set CellulesUtilisees = CreateObject("Scripting.Dictionary") CellulesVoisines CellulesUtilisees, rngTrouve, mot, 1 If Indic = Len(mot) - 1 Then Flag = True For Indic = LBound(T_Out) To UBound(T_Out) If Range(T_Out(Indic)).Value <> Mid(mot, Indic + 1, 1) Then Flag = False: Exit For Next Indic Else Flag = False End If If Flag Then Exit Do Loop While Not rngTrouve Is Nothing And rngTrouve.Address <> firstAddress End If If Flag Then ReDim Preserve 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").Cells(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 Each Cel In Plage If Indic + 1 = Len(Strmot) Then Exit For If Cel.Value = Mid(Strmot, niveau + 1, 1) Then Flag = True For Each c In Obj.Keys If c = Cel.Address Then Flag = False Next If Flag Then 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 If Next Cel End Sub Add to a standard module: From your spreadsheet, press ALT + F11 Insert/Module.

Notes

Above all, pay particular attention to columns in Sheet2: Column B (from B2 to BX: 3-letter words), Column C (from C2 to Cx: 4-letter words), ..... , Column G(from G2 to Gx: 8-letter words)