O jogo no Excel - VBA : "Le Boggle"





Regra do jogo

Tirado de um artigo wikipédia.
O jogo começa pela mistura de uma bandeja (quadrado ) de 16 dados com 6 faces. Os dados são lançados. Cada dado possui uma letra diferente em cada uma de suas faces. Os dados são organizados na bandeja de quatro em quatro, e somente sua face superior é visível. Depois desta operação, uma contagem regressiva de 3 minutos é lançada e todos os jogadores começam a jogar.


Cada jogador busca palavras que podem ser formadas a partir de letras adjacentes da bandeja. Por «adjacentes», entende-se horizontalmente, verticalmente ou em diagonal. As palavras devem ser de 3 letras no mínimo, podendo ser no singular ou no plural, conjugadas ou não, mas não se deve utilizar varias vezes o mesmo dado para a mesma palavra. Os jogadores escrevem todas as palavras que são encontradas na sua folha pessoal. Depois de 3 minutos de busca, os jogadores devem parar de escrever e o jogo entra na fase de cálculo dos pontos.

Se dois jogadores ou mais encontraram a mesma palavra, ela é riscada das listas que a contém. Todos os jogadores devem verificar a validade de uma palavra. Depois de ter eliminado as palavras comuns as listas dos jogadores, os pontos são atribuídos de acordo com o tamanho das palavras encontradas. O ganhador é o jogador que tem o maior número de pontos.

Palavras de 3 e 4 letras = 1 ponto, palavras de 5 letras = 2 pontos, palavras de 6 letras = 3 pontos, palavras de 7 letras = 5 pontos, palavras de 8 letras = 11 pontos.

Pré-requisito :

Na sua planilha Boggle.xls, é preciso ter uma grade para acolher as 16 letras. Para tanto, nós vamos nomear um conjunto de 4 células, no exemplo l D2 :G5 como segue:
  • Inserir um nome definido:
    • Menu : Inserção
    • Escolha : Nome
    • Clicar em Definir


Nomes na planilha => digitar: grade
Faz referência à => digitar: =Fol1!$D$2:$G$5
Clicar em Adicionar .

Os códigos VBA

A ser inserido no módulo standard:
A partir de sua planilha de cálculo, digite ALT+F11, Inserção/Módulo.

 Opção Explicita       
'Variáveis de dimensão « módulo"
Dim Endereços(), p&
Dim ListaPalavras() As String
Dim alfabeto(25)
Dim grade(1 To 4, 1 To 4)
Dim t_Out()
Dim Indic&, NumCol&, PalavrasTratadas As Long

'Procedimento principal que serve de chamada para os outros procedimentos
Sub Aleatória_ProcedimentoPrincipa()
Dim Wsh As Worksheet, NbrePalavrasEncontradas As Long, i&, j&, cpt

PalavrasTratadas = 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

ListarPalavras Wsh, NumCol

RetirarPalavrasLetrasAusentes

PalavrasNaGrade
Next
For i = 3 To 8
NbrePalavrasEncontradas = NumeroPalavrasEncontradas + (Columns(i).Find("*", , , , xlByColumns, xlPrevious).Row - 9)
Next
Sheets("Feuil1").Range("E7") = "Número de palavras encontradas : " & NbrePalavrasEncontradas
End Sub

'Sorteio das letras (de acordo com a regra do bogle), a comandar a partir de um botão na folha
Sub SorteioMenos aleatório()
Dim i&
For i = 0 To 25
alphabet(i) = Chr(65 + i)
Next
Randomize
Range("D2") = Mid("ETUKNO", CInt(Int((6 * Rnd()) + 1)), 1)
Randomize
Range("D3") = Mid("EVGTIN", CInt(Int((6 * Rnd()) + 1)), 1)
Randomize
Range("D4") = Mid("IELRUW", CInt(Int((6 * Rnd()) + 1)), 1)
Randomize
Range("D5") = Mid("DECAMP", CInt(Int((6 * Rnd()) + 1)), 1)
Randomize
Range("E2") = Mid("EHIFSE", CInt(Int((6 * Rnd()) + 1)), 1)
Randomize
Range("E3") = Mid("RECALS", CInt(Int((6 * Rnd()) + 1)), 1)
Randomize
Range("E4") = Mid("ENTDOS", CInt(Int((6 * Rnd()) + 1)), 1)
Randomize
Range("E5") = Mid("OFXRIA", CInt(Int((6 * Rnd()) + 1)), 1)
Randomize
Range("F2") = Mid("NAVEDZ", CInt(Int((6 * Rnd()) + 1)), 1)
Randomize
Range("F3") = Mid("EIOATA", CInt(Int((6 * Rnd()) + 1)), 1)
Randomize
Range("F4") = Mid("GLENYU", CInt(Int((6 * Rnd()) + 1)), 1)
Randomize
Range("F5") = Mid("BMAQJO", CInt(Int((6 * Rnd()) + 1)), 1)
Randomize
Range("G2") = Mid("TLIBRA", CInt(Int((6 * Rnd()) + 1)), 1)
Randomize
Range("G3") = Mid("SPULTE", CInt(Int((6 * Rnd()) + 1)), 1)
Randomize
Range("G4") = Mid("AIMSOR", CInt(Int((6 * Rnd()) + 1)), 1)
Randomize
Range("G5") = Mid("ENHRIS", CInt(Int((6 * Rnd()) + 1)), 1)
End Sub

'Apaga as letras e as soluções a partir de um botão na folha
Sub Apaga()
Sheets("Fol1").Linha("C10:H65536").Clear
Sheets("Fol1").Linha("E7").ClearContents
Sheets("fol1").Linha("grille").ClearContents
End Sub

'Lista todas as palavras (soluções) na folha Fol2
Sub ListarPalavras(Sh As Worksheet, ByVal Col As Integer)
Dim i&, j&

Erase ListaPalavras
With Sh
For i = 0 To .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
ReDim Preserve ListaPalavras(j)
ListaPalavras(j) = .Cells(i + 2, Col)
j = j + 1
Next
End With
PalavrasTratadas = PalavrasTratadas + UBound(ListaPalavras)
End Sub

'Tira da lista, as palavras contendo letras que não fazem parte do sorteio
Sub RetirarPalavrasLetrasAusentes ()
Dim letrasutilizadas(), letrasausentes()
Dim ListaPalavrasTemp() As String, lettr$, mot$
Dim i&, j&, k&, test As Boolean
Dim MonDico1 As Object, MonDico2 As Object, c

letrasutilizadas = linha("grade") '-----> Menu Inserção/Nomes/Definir
Set MonDico1 = CreateObject("Scripting.Dictionary")
For Each c In letrasutilizadas
MonDico1(c) = ""
Next c
Set MonDico2 = CreateObject("Scripting.Dictionary")
For Each c In alphabet
If Not MonDico1.Exists(c) Then MonDico2(c) = ""
Next c
letrasausentes = Aplicação.Transpõe(MonDico2.Keys)
ListaPalavrasTemp = ListaPalavras
Erase ListaPalavras
For i = 0 To UBound(ListaPalavrasTemp)
mot = ListaPalavrasTemp(i)
For j = 1 To UBound(letrasausentes)
lettr = letrasausentes(j, 1)
If InStr(mot, lettr) = 0 Then
test = True
Else
test = False
Exit For
End If
Next j
If test Then
ReDim Preserve ListaPalavras(k)
ListaPalavras(k) = ListaPalavrasTemp(i)
k = k + 1
End If
Next i
End Sub

'Procedimento de busca das palavras
Sub PalavrasNaGrade()
Dim PalavrasEncontradasNaGrade(), k&, l&
Dim Cel As Range, mot, firstAddress$, a$, c, dico As Object, mondico As Object

For Each mot In ListaPalavras
On Error Resume Next
Erase Endereços
p = 0
Set Cel = Range("D2:G5").Cells.Find(Left(mot, 1))
If Not Cel Is Nothing Then
ReDim Preserve Adresses(p)
Adresses(p) = Cel.Address
p = p + 1
CélulasVizinhas Cel, mot, 1
If UBound(Adresses) = Len(mot) - 1 Then
Set dico = CreateObject("Scripting.Dictionary")
For Each c In Adresses
If Not dico.exists(c) Then
dico(c) = c
Else
GoTo palavraseguinte
End If
Next c
ReDim Preserve PalavrasEmcontradasNaGrade(k)
PalavrasEncontradasNaGrade(k) = mot
GoTo palavraseguinte
k = k + 1
End If
firstAddress = Cel.Address
Do
Set Cel = Range("D2:G5").Cells.FindNext(Cel)
Erase Adresses
p = 0
ReDim Preserve Adresses(p)
Adresses(p) = Cel.Address
p = p + 1
CélulasVizinhas Cel, mot, 1
If UBound(Adresses) = Len(mot) - 1 Then
Set dico = CreateObject("Scripting.Dictionary")
For Each c In Adresses
If Not dico.exists(c) Then
dico(c) = c
Else
GoTo palavraseguinte
End If
Next c
ReDim Preserve PalavrasEncontradaNaGrade(k)
PalavrasEncontradaNaGrade(k) = mot
k = k + 1
End If
Loop While Not Cel Is Nothing And Cel.Address <> firstAddress
End If
palavrasuivant:
Next mot
If k <> 0 Then
Set mondico = CreateObject("Scripting.Dictionary")
For k = LBound(PalavrasTouvesDansGrille) To UBound(PalavrasEncontradaNaGrade)
mondico(PalavrasEncontradaNaGrade(k)) = ""
Next k
Sheets("Fol1").Cells(10, NumCol + 1).Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
End If
End Sub
'Em função das células vizinhas -procedimento recursivo.
Sub CélulasVizinhase(CelInicial, Strmot, nível)
Dim Cel As Range, Conjunto As Range, Lettr As Byte, cpt&, flag As Boolean, elem

Set Conjunto = Range(CelInicial.Offset(-1, -1), CelInicial.Offset(1, 1))
cpt = 0
For Each Cel In Plage
If p > Len(Strmot) - 1 Or nível = Len(Strmot) Then Exit For
cpt = cpt + 1
flag = False
For Each elem In Adresses
If Cel.Address = elem Then flag = True: Exit For
Next
If Cel.Value = Mid(Strmot, nível + 1, 1) And flag = False Then
ReDim Preserve Adresses(p)
Adresses(p) = Cel.Address
p = p + 1
nível = nível + 1
CélulasVozinhas Cel, Strmot, nível
End If
Next Cel
If cpt = 9 Then nível = nível - 1: p = p - 1
End Sub

Precauções de emprego

Sobretudo, respeite as colunas na Fol2 : Coluna B, de B2 à Bx : palavras de 3 letras, Coluna C, de C2 à Cx : palavras de 4 letras, ..... , Coluna G, de G2 à Gx : palavras de 8 letras.

O arquivo é bastante pesado (3Mo), mas é por causa daquilo que ele contém: uma lista de mais de 80 000 palavras...

Download

Você pode baixar a planilha fonte exemplo.

Além das planilhas, você poderá encontrar abaixo seguindo este link, o jogo na tabuleiro (UserForm). Nele, faça uma partida contra o computador...Não se preocupe, ele não encontra todas as palavras, sempre!
Artigo original publicado por jak58. Tradução feita por ninha25. Última modificação: 8 de fevereiro de 2018 às 08:41 por ninha25.
Este documento, intitulado 'O jogo no Excel - VBA : "Le Boggle"', está disponível sob a licença Creative Commons. Você pode copiar e/ou modificar o conteúdo desta página com base nas condições estipuladas pela licença. Não se esqueça de creditar o CCM (https://br.ccm.net/) ao utilizar este artigo.
Transpor linhas e colunas
Excel - Concatenar dados