O jogo no Excel - VBA : "Le Boggle"

Fevereiro 2017





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!

Tradução feita por Ana Spadari

Veja também

Artigo original publicado por . Tradução feita por ninha25. Última modificação: 8 de agosto de 2013 às 17:16 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 (br.ccm.net) ao utilizar este artigo.