Excel/VBA - the Boggle game

December 2016




The rules of the game


As explained on Wikipedia...http://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:
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)
  • The file is quite heavy (3MB), as it contains a list of over 80,000 words ...
  • Download file here



Related :

This document entitled « Excel/VBA - the Boggle game » from CCM (ccm.net) is made available under the Creative Commons license. You can copy, modify copies of this page, under the conditions stipulated by the license, as this note appears clearly.