Auteur Topic: Scrabble-tester (gelezen 11611 keer)

LucB · « **Gepost op:** 19 maart 2007, 14:07:12 »

Dag allemaal,

Zo af en toe wordt er bij ons gescrabbeld.
Je hebt 7 letters op je plankje en denkt daar moet toch een 7-letterwoord in zitten.

Kortom ik wil daarbij de hulp van Excel inroepen.

In onderstaand bestand doe ik een poging.

Graag jullie hulp om een en ander sneller te maken.
En hoe kom ik van die onzin-woorden af.

Alvast dank voor de aandacht.

Erik Van Geit · « **Reactie #1 Gepost op:** 19 maart 2007, 22:12:28 »

Dag, Luc,

Dat is een hele boterham!

Ik vind het handiger om de code bij de hand te hebben dan in een link. Dit is dus je code.

Code: [Selecteer]

Public Function scramble(s As Variant)
    Dim R As Long, I As Long
    On Error Resume Next
    Dim CL     As New Collection
    Application.Volatile
    scramble = ""
    Do Until CL.Count = Len(s)
        R = Int(1 + Rnd * Len(s))
        CL.Add R, CStr(R)
    Loop

    For I = 1 To CL.Count
        scramble = scramble & Mid(s, CL(I), 1)
    Next

End Function

Sub test()
    Calculate
    Do Until Application.CheckSpelling(Range("B1").Value) = True
        Range("B1").FormulaR1C1 = "=scramble(RC[-1])"
    Loop
End Sub

De code die je gebruikt heeft verschillende elementen die voor grote vertraging zorgen.

Je schrijft hier telkens weer dezelfde formule naar B1: kost veel tijd...Het blijft maar "loop-en" tot er eindelijk iets met juiste spelling staat.

Code: [Selecteer]

    Do Until Application.CheckSpelling(Range("B1").Value) = True
        Range("B1").FormulaR1C1 = "=scramble(RC[-1])"
    Loop

Even kijken hoe de functie werkt:

Code: [Selecteer]

    Do Until CL.Count = Len(s)
        R = Int(1 + Rnd * Len(s))
        CL.Add R, CStr(R)
    Loop

Je draait hier willekeurig rondjes tot alle 7 letters gebruikt zijn. (het kan dus ettelijke keren "ronddraaien" voor eindelijk die 7de letter wordt gevonden) Bovendien ga je in de volgende "loop" (gestuurd vanuit "test")weer mogelijk op dezelfde combinatie uitkomen.
Het is beter code te maken die de 7 letters omzet naar alle mogelijke permutaties.
De meest bekende code om dit te doen is van Myrna Larson
https://groups.google.com/group/microsoft.public.excel.misc/msg/2150eee92452c83c

Wat checkspelling betreft: je hoeft niet persé een cel te testen: het gaat ook gewoon zo:

Code: [Selecteer]

MsgBox Application.CheckSpelling("hallo")
MsgBox Application.CheckSpelling("hllo")

Samengevat:
1. gebruik de code van Myrna Larson
2a. schrijf alleen naar je werkblad als er een geldig woord gevonden is
2b. nog beter is het om alle geldige woorden in een array op te slaan en op het einde alle suggesties te tonen

beste groeten,
Erik

LucB · « **Reactie #2 Gepost op:** 19 maart 2007, 22:38:42 »

Hallo Erik,

Fijn je hier te ontmoeten.

Ik heb flink wat huiswerk van je gekregen.
Ik ga er mee aan de slag en laat wel van me horen.

Heel hartelijk dank voor de tijd die je er in hebt gestoken.

Met vr. groet,
Luc

Erik Van Geit · « **Reactie #3 Gepost op:** 19 maart 2007, 23:21:34 »

Citaat van: LucB

Fijn je hier te ontmoeten.

Deed me vermoeden dat je ook op een ander forum zit: 'k heb het effe nagekeken en gevonden

Citaat

Ik ga er mee aan de slag en laat wel van me horen.

'k Heb mijn zetel bij het scherm staan en wacht op je: gewoon effe bellen

RedHead · « **Reactie #4 Gepost op:** 20 maart 2007, 00:01:48 »

Nouhou Erik, daar heb je een mooi stuk code boven water gekregen. Super.
Ik heb er ff mee zitten spelen en het is echt leuk. Nou heb ik een vraag aan jou.. Ik dacht dus ff een functie te schrijven die je vervolgens in je worksheet gebruikt om de uitkomst van de combinaties te tonen als 'echt woord' of als lege cel... Enne, het maken van die functie was ook om ff met de functie CheckSpelling te spelen... (die kende ik nog niet)
Mijn functie blijft heel vervelend mij het verkeerde antwoord geven. Het vreemde is dat als je het eea in in sub gooit, HET WEL GOED GAAT! Om GEK van te worden!!!

WAT DOE IK FOUT?
(de msgboxjes staan er ff tussen om te kijken waar ik in de code ben...)
(Voor de volledigheid... in cel A1 staat "k, i, e, z, e, n" het resultaat van de code van Myrna Larson. In cel B1 zou dan mijn functie =TestWoord staan)

Code: [Selecteer]

Function TestWoord(Combinatie As String) As String
Dim Woord As String

MsgBox Combinatie
    Woord = Replace(Combinatie, ", ", "")
    If Application.CheckSpelling(Woord) = True Then
MsgBox "true"
        TestWoord = Woord
    Else:
MsgBox "false"
        TestWoord = ""  '#N/A
    End If

End Function

Code: [Selecteer]

Sub TestWord()
Dim Woord As String, Combinatie As String, TestWord As String
Combinatie = ActiveCell.Value

    Woord = Replace(Combinatie, ", ", "")
MsgBox Len(Woord)
    If Application.CheckSpelling(Woord) = True Then
MsgBox "true"
        TestWord = Woord
    Else:
MsgBox "false"
        ActiveCell.Offset(, 2).Value = Woord '= ""  '#N/A
    End If

End Sub

Groet, Leo

Erik Van Geit · « **Reactie #5 Gepost op:** 20 maart 2007, 09:38:56 »

Hoi, Leo,

Functies hebben hun beperkingen: ik geloof niet dat checkspelling binnen een functie kan werken.
een simpele test

Code: [Selecteer]

If Application.CheckSpelling("kies") Then MsgBox "test ok"Geen popup wanneer je dit in een functie zet.

tot kijk!
Erik

RedHead · « **Reactie #6 Gepost op:** 20 maart 2007, 09:41:15 »

Citaat van: Erik

Functies hebben hun beperkingen

Aha... dat verklaart een hoop!

Dat had ik gisteren een uurtje eerder moeten weten.

Groet, Leo

Erik Van Geit · « **Reactie #7 Gepost op:** 20 maart 2007, 10:42:55 »

Leo,

Wat me ontgaan was in je vorige post:

Citaat

in cel A1 staat "k, i, e, z, e, n" het resultaat van de code van Myrna Larson.

Bedoel je dat je op basis van een aantal "losse letters" er in geslaagd bent om een "echt" woord te genereren?
Misschien nuttig voor Luc ...

LucB · « **Reactie #8 Gepost op:** 20 maart 2007, 11:18:38 »

Hallo Erik,

In mijn archief zat nog een permutatie-code van
John Walkenbach.

(Makkelijker qua invoer en output zonder komma's.)

Code: [Selecteer]

Option Explicit
Dim CurrentRow

Sub GetString()
    Dim InString As String
    InString = InputBox("Voer 7 letters in,svp.")
    If Len(InString) < 2 Then Exit Sub
    If Len(InString) >= 8 Then
        MsgBox "Teveel letters!  Maximaal 7 letters."
        Exit Sub
    Else
        ActiveSheet.Columns(1).Clear
        CurrentRow = 1
        Call GetPermutation("", InString)
    End If
End Sub

Sub GetPermutation(x As String, y As String)
    Dim i As Integer, j As Integer
    j = Len(y)
    If j < 2 Then
        Cells(CurrentRow, 1) = x & y
        CurrentRow = CurrentRow + 1
    Else
        For i = 1 To j
            Call GetPermutation(x + Mid(y, i, 1), _
                                Left(y, i - 1) + Right(y, j - i))
        Next
    End If
End Sub

Om de code voor CheckSpelling te versnellen gaat nog even boven m'n petje.

Groet,
Luc

Erik Van Geit · « **Reactie #9 Gepost op:** 20 maart 2007, 17:31:01 »

Hallo,

de komma's zijn niet moeilijk uit de andere code te halen, denk ik
'k heb niet getest of Walkenbachs code sneller is, maar ik vrees van niet: (in elk geval is ze in de huidige toestand erg traag, want ze schrijft naar cellen, maar dat stukje laten we uiteraard weg: we schrijven enkel wanneer het nodig is)

even wachten op Leo's antwoord, want het zag er naar uit dat hij al code heeft ...

tot binnenkort,
Erik

PS: de code is eigenlijk niet van John W: hij schreef "' The source of this algorithm is unknown"

RedHead · « **Reactie #10 Gepost op:** 20 maart 2007, 17:43:02 »

Heren, wat ik dus probeerde met mijn functie was de kolom met permutaties om te zetten naar een nederlands woord als deze bestond, en anders een lege cel.
Ik wilde de code van Myrna Larson laten runnen op het woord 'kiezen'. Dit woord had ik volgens de regels ingetikt en vervolgens op alfabet gesorteerd. Er stond dus vervolgens 'eeiknz' en hier is het programma mee aan de slag gegaan. Dit leverde zo'n 800 mogelijkheden op die keurig in kolom A onder elkaar stonden. Ik wilde dus met mijn functie '=TestWoord(A1)' in cel B1 (en natuurlijk helemaal naar de laatste cel van het bereik) bereiken dat alléén de nederlandse woorden getoond werden. En alle 'troep' als lege cel. Zo zou je dus heel snel kunnen kijken wat de goede oplossingen waren...

Maar dus helaas...

Misschien dat ik straks thuis nog ff door rommel met het subje...

Groet, Leo

LucB · « **Reactie #11 Gepost op:** 20 maart 2007, 19:01:59 »

Hallo Leo,

Als je straks nog even gaat rommelen, zou je dan een 7- letterwoord willen testen.

bv: "voetpad" en dan gehusseld invoeren.

We zullen The Hall of Fame in gereedheid brengen.

Erik Van Geit · « **Reactie #12 Gepost op:** 20 maart 2007, 21:36:43 »

Laat de Fame er nog even af, maar dit kan toch al in een Hall, want het werkt, zij het traag: er wordt immers voor elke permutatie spellingcontrole uitgevoerd.
Ik heb de code bewerkt die je eerder toonde, mogelijk is Myrnas code nog wat sneller.
In de statusbalk kan je zien of er al wat gevonden is. Eventueel kan de code worden beëindigd - zonder debugvenster - met "escape".

Code: [Selecteer]

Option Explicit

Dim CurrentRow
Const col = 2

Sub correctly_spelled_permutations()
Dim InString As String
Dim CalcSet As Integer
    
    InString = Range("A1")
    If Len(InString) < 2 Then Exit Sub

    With Application
    .ScreenUpdating = False
    CalcSet = .Calculation
    .Calculation = xlCalculationManual
    .EnableCancelKey = xlErrorHandler
    .StatusBar = "searching valid combination"
    End With

On Error GoTo skip
CurrentRow = 0

    'If Len(InString) > 8 Then
        'MsgBox "To many permutations!"
        'Exit Sub
    'Else
        ActiveSheet.Columns(col).Clear
        Call GetPermutation("", InString)
    'End If

skip:
    With Application
    .Calculation = CalcSet
    .ScreenUpdating = True
    .StatusBar = False
    End With

End Sub

Sub GetPermutation(x As String, y As String)
'The source of this algorithm is unknown
Dim i As Integer, j As Integer
j = Len(y)
    
    With Application
        If j < 2 Then
            If .CheckSpelling(x & y) Then
            CurrentRow = CurrentRow + 1
            ActiveSheet.Cells(CurrentRow, col) = x & y
            .StatusBar = "# of valid combinations: " & CurrentRow
            End If
        Else
            For i = 1 To j
            Call GetPermutation(x + Mid(y, i, 1), _
            Left(y, i - 1) + Right(y, j - i))
            Next
        End If
    End With
    
End Sub

resultaat
  A     B
1 troeb ebtor
2       ebrot
3       boter
4       boert

Blad1
[Table-It] version 06 by Erik Van Geit

De eerste 2 woorden zijn van het "theoretische soort", maar de volgende 2 mogen er zijn

de groeten,
Erik

Erik Van Geit · « **Reactie #13 Gepost op:** 20 maart 2007, 22:01:50 »

Citaat van: LucB op 20 maart 2007, 19:01:59

zou je dan een 7- letterwoord willen testen.
bv: "voetpad" en dan gehusseld invoeren.

   A       B
1 vpdatoe vatdope
2 842,17  vodtape
3         voedtap
4         voetpad
5         vetopad
6         padvoet
7         padveto
8         potveda
9         dopevat
10         depvota
11         tapdove
12         tapevod
13         topveda

Blad1
[Table-It] version 06 by Erik Van Geit
het getal is de tijd in seconden die mijn machine nodig had: 14 minuten dus (de tijd om de was in te steken en een wafeltje te eten)

weer veel geleerd vanavond
1. de beste veda is de "topveda"
2. wil je enkele geloftes om je gelaat mee te drogen, kies dan voor "depvota"
3. wil je graag een stukje kleefband opnieuw gebruiken, maak het dan even proper met een "tapevod"

LucB · « **Reactie #14 Gepost op:** 20 maart 2007, 22:13:25 »

Hallo Erik,

Het is geweldig, wat een speed.

Zou je hetzelfde -voetpad- willen betreden met dit fraais?

1e GetString
2e Test

Code: [Selecteer]

Option Explicit
Dim CurrentRow

Sub GetString()
    Dim InString As String
    Dim n As Long
    Range("B1") = ""
    InString = InputBox("Voer 7 letters in,svp.")
    If Len(InString) < 2 Then Exit Sub
    If Len(InString) >= 8 Then
        MsgBox "Teveel letters!  Maximaal 7 letters."
        Exit Sub
    Else
        ActiveSheet.Columns(1).Clear
        CurrentRow = 1
        Call GetPermutation("", InString)
    End If
    For n = 1 To 3
    Call DubbelData
    Next n
    Range("B1").Formula = "=COUNTA(C[-1])"
End Sub

Sub GetPermutation(x As String, y As String)
    Dim i As Integer, j As Integer
    j = Len(y)
    If j < 2 Then
        Cells(CurrentRow, 1) = x & y
        CurrentRow = CurrentRow + 1
    Else
        For i = 1 To j
            Call GetPermutation(x + Mid(y, i, 1), _
                                Left(y, i - 1) + Right(y, j - i))
        Next
    End If
    
End Sub

Sub DubbelData()
    Dim x      As Long
    Dim r      As Range
    Dim n      As Long
    Dim i      As Integer
    For i = 1 To 4
      
        Range("A1:A5040").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
                       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        Range("A1").Select
        x = Cells(Rows.Count, "A").End(xlUp).Row
        Set r = Range("A1:A" & x)
        For n = 1 To x
            If r.Cells(n, 1) = r.Cells(n + 1, 1) Then
                r.Cells(n + 1, 1).ClearContents
            End If
        Next n
        
        Range("A1:A5040").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
                       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        Range("A1").Select
    Next i
End Sub

Sub Test()
    Dim rng    As Range
    Dim x      As Long
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Set rng = Range("A1:A" & Range("A65536").End(xlUp).Row)
    For x = rng.Rows.Count To 1 Step -1
        If Application.CheckSpelling(rng.Cells(x, 1).Value) = False Then
            rng.Cells(x, 1).Delete Shift:=xlUp
        End If
    Next x
    Set rng = Nothing
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Bij mij duurde het 4 minuten en 40 seconden.

Help!

Menu

Hulp bij posten

Zoeken

Recente topics

Auteur Topic: Scrabble-tester (gelezen 11611 keer)

LucB

Scrabble-tester

Erik Van Geit

Re: Scrabble-tester

LucB

Re: Scrabble-tester

Erik Van Geit

Re: Scrabble-tester

RedHead

Re: Scrabble-tester

Erik Van Geit

Re: Scrabble-tester

RedHead

Re: Scrabble-tester

Erik Van Geit

Re: Scrabble-tester

LucB

Re: Scrabble-tester

Erik Van Geit

Re: Scrabble-tester

RedHead

Re: Scrabble-tester

LucB

Re: Scrabble-tester

Erik Van Geit

Re: Scrabble-tester

Erik Van Geit

Re: Scrabble-tester

LucB

Re: Scrabble-tester