# Excel/VBA - the Boggle game

## The rules of the game

As explained on Wikipedia...https://en.wikipedia.org/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:
Choice: Nom
Click: Définir

Names in workbook => type: grille
Refers to => enter: Feuil1!\$D\$2:\$G\$5

## 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)
Set CellulesUtilisees = CreateObject("Scripting.Dictionary")
CellulesVoisines CellulesUtilisees, rngTrouve, mot, 1
Do
Set rngTrouve = Range("grille").Cells.FindNext(rngTrouve)
Erase T_Out
Indic = 0
ReDim Preserve T_Out(Indic)
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))
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)
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)

• The file is quite heavy (3MB), as it contains a list of over 80,000 words ...