Word Descrambler

[bdmangum]

Hey guys,

The other day I was playing around and thought it might be fun to try and build a word descrambler in Excel using VBA. Most places online tend to use C++ or some scripting language to run this sort of code.

My thought was to store the list of possible words in a spreadsheet. Below is the code I currently have written. I'm somewhat stuck as to how to write the algorithm to work for an input word of any length. If I set a limit on the length of the word, the code is simple. But how can it work with an unknown word length? Any thoughts?

Note that some of the code is simply testing the command within the intented context (ie the checkspelling command) and not the actual implementation of the command. My code is in the very early stages.

Sub WordGen()

Dim strWord As String, lenWord As Integer, count As Integer, isWord As Boolean
Dim lArray()

'Set variables
    strWord = InputBox("Input word or letters to be descrambled.", "Word Descrambler")
    lenWord = Len(strWord)
    ReDim lArray(lenWord - 1)
    ThisWorkbook.Sheets(1).Range("A2").Value = strWord
    
'Loop through letters to fill array
    For i = 0 To lenWord - 1
        lArray(i) = LCase(Right(Left(strWord, i + 1), 1))
    Next
    
    iLet = LCase(Right(Left(strWord, i), 1))
    
    Application.DisplayAlerts = False
    isWord = ThisWorkbook.Sheets(1).Range("A2").CheckSpelling
    Application.DisplayAlerts = True
        
End Sub

Thanks,
BD

 

[ck1999]

If I set a limit on the length of the word, the code is simple.
But how can it work with an unknown word length?

What is the simple code? for say a word with 5 letters?

How are you going to have a word with unknown length?

ck1999

 

[HarleyQuinn]

I was pretty confused by that part as well...

HarleyQuinn
---------------------------------
The most overlooked advantage to owning a computer is that if they foul up there's no law against wacking them around a little. - Joe Martin

Get the most out of Tek-Tips, read FAQ222-2244 before posting.

 

[fumei]

Me too. Especially as you have:

lenWord = Len(strWord)

which IS the length...so why is it unknown???

Although it could be that you should be using Redim Preserve.


faq219-2884

Gerry
My paintings and sculpture

 

[bdmangum]

For a word with say 5 letters I can simply write five sequencial loops which order the five letters into all the possible words. I can check if the new word is valid by simply performing a word check on the word after each letter. Meaning I can check if the first two letters form a word, the first three, ...

Here is a short example, I'm using three letters for the sake of time. I need to find a better way to check if the word is valid other than CheckSpelling.

Sub WordGen()

Dim strWord As String, lenWord As Integer, count As Integer, isWord As Boolean
Dim lArray(), tempWord As String, Dictionary As Object

'Set variables
    ThisWorkbook.Sheets(1).Range("B3").Value = "Filler"
    ThisWorkbook.Sheets(1).Range(Cells(2, 2), Range("B2").End(xlDown)).ClearContents
    strWord = InputBox("Input word or letters to be descrambled.", "Word Descrambler")
    lenWord = Len(strWord)
    If lenWord = 0 Then Exit Sub
    ReDim lArray(lenWord - 1)
    ThisWorkbook.Sheets(1).Range("A2").Value = strWord
    count = 2
    Set Dictionary = CreateObject("Scripting.Dictionary")
    
'Word length of three
    Application.DisplayAlerts = False
    For i = 1 To 3
        tempWord = LCase(Right(Left(strWord, i), 1))
        For j = 1 To 3
            If j <> i Then
                tempWord = LCase(Right(Left(strWord, i), 1)) + LCase(Right(Left(strWord, j), 1))
                ThisWorkbook.Sheets(1).Range("A5").Value = tempWord
                isWord = ThisWorkbook.Sheets(1).Range("A5").CheckSpelling
                If isWord = True Then
                    ThisWorkbook.Sheets(1).Cells(count, 2).Value = tempWord
                    count = count + 1
                    isWord = False
                End If
                For k = 1 To 3
                    If k <> i And k <> j Then
                        tempWord = LCase(Right(Left(strWord, i), 1)) + LCase(Right(Left(strWord, j), 1)) + LCase(Right(Left(strWord, k), 1))
                        ThisWorkbook.Sheets(1).Range("A5").Value = tempWord
                        isWord = ThisWorkbook.Sheets(1).Range("A5").CheckSpelling
                        If isWord = True Then
                            ThisWorkbook.Sheets(1).Cells(count, 2).Value = tempWord
                            count = count + 1
                            isWord = False
                        End If
                    End If
                Next
            End If
        Next
    Next
    Application.DisplayAlerts = True
    ThisWorkbook.Sheets(1).Range("A5").Value = ""

End Sub

The two things to do now are expand this to a word of n length and find a better method for checking if the word is in the dictionary.

 

[ck1999]

So you are not only descrambling but determining words made up of characters that can be inside of a list of characters.

for example: tihel

would return
tie
tile
hi
hit
the
lie
lit

am I understanding you correctly?

ck1999

 

[bdmangum]

ck1999,

Correct. Any word within the given letters should be listed.


Gerry,

The length is unknown not because I can't determine it, but because the user could insert a word of any length. As shown, I can easily write the loops needed for a restricted word length, but my goal was to create the code with an unknown word length. True I could simply find the longest word in the dictionary and create the equivalent cascade of loops, but that seems very inefficient and perhaps the inputted word or string of letters would be longer still.

 

[AnotherHiggins]

Well a resulting word cannot contain more letters than are given. So just determine the length of the string provided (let's call than InputLen) and loop through that many times:

for i = 1 to InputLen

[tt]_____
[blue]-John[/blue][/tt]
[tab][red]The plural of anecdote is not data[/red]

Help us help you. Please read FAQ 181-2886 before posting.

 

[fumei]

Is he not already doing that with:

For i = 0 To lenWord - 1

?????

"True I could simply find the longest word in the dictionary and create the equivalent cascade of loops, but that seems very inefficient"

I think that is putting it mildly....

Even with a 3 letter input there is a heck of a lot of looping going on. Hmmmm, I don't know. This seems a very brute force method, and I am not understanding the reason or purpose for it.

faq219-2884

Gerry
My paintings and sculpture

 

[bdmangum]

Gerry,

The approach used for a 3 letter word is very much brute force, thus my goal to devise a better method. I currently am stuck as to how to build this for an n letter word.

There isn't really any reason for the code other than solving the challenge. I saw a person attempt to build the code for something like this using C++ and it grabbed my attention. I like VBA coding and wondered if I could do the same thing in it as opposed to C++. Heck maybe I'll use it next time I play Scrabble!

There has to be a way to descramble without a cascade of loops.

 

[macropod]

Hi bdmangum,

Do you really want to do this? Consider for a moment how many permutations there are for a string of a given length:
1 1
2 2
3 6
4 24
5 120
6 720
7 5,040
8 40,320
9 362,880
10 3,628,800
11 39,916,800
12 479,001,600
13 6,227,020,800
14 87,178,291,200
15 1,307,674,368,000
16 20,922,789,888,000

In this light, I suggest you think seriously about placing an upper limit on the string length.

In any event, here's some Word vba code I picked up somewhere. It inserts all letter permutations into a new Word document, but can easily be modified to work with other Office Apps. It would need more work to extract only the unique valid word sub-strings too.

Sub Permutations()
' Select a string, then run the macro
Dim strTest As String
Dim strOut
Dim i As Long
Dim j As Long
Dim pos As Long
strTest = Selection.Text
strOut = Mid(strTest, 1, 1)
strOut = StringString(2, strOut & " ")
strOut = RTrim(strOut)

For j = 2 To Len(strTest)
	strOut = Split(strOut, " ")
	' weave
	For i = 0 To UBound(strOut)
		pos = i Mod (2 * j)
		pos = pos - (j - 1)
		Select Case pos
		Case Is <= 0
			pos = Abs(pos)
		Case Else
			pos = pos - 1
		End Select
		strOut(i) = InsertString((strOut(i)), _
		Mid(strTest, j, 1), pos)
	Next i
	If j < Len(strTest) Then
		For i = 0 To UBound(strOut)
		strOut(i) = _
		  StringString(j + 1, strOut(i) & " ")
		Next i
	End If
	strOut = Join(strOut, " ")
	strOut = Replace(strOut, "  ", " ")
	strOut = RTrim(strOut)
Next j
Documents.Add
Selection.InsertAfter strOut
End Sub
Function InsertString(strOld As String, strInsert As String, pos As Long) As String
' Inserts strInsert into strOld at position pos
InsertString = Left(strOld, pos) & strInsert & Mid(strOld, pos + 1)
End Function
Function StringString(imax As Long, myString As String) As String
' Comparable to String(). Creates string of imax times the string myString
Dim i As Long
If imax < 0 Then MsgBox "imax < 0", vbCritical
i = 0
StringString = ""
Do While i < imax
	Select Case i
	Case 0, Is >= imax / 2
		StringString = StringString & myString
		i = i + 1
	Case Else
		StringString = StringString & StringString
		i = 2 * i
	End Select
Loop
End Function

Cheers

[MS MVP - Word]

 

[fumei]

It would need more work to extract only the unique valid word sub-strings too.

which is precisely what the OP is trying to achieve....I think. Not only that, but valid is passed through spellingchecking.

I don't know. Interesting. By all means if you get this thing actually running fast enough to be useful, shrug, post code! I play Scrabble.

faq219-2884

Gerry
My paintings and sculpture

 

[combo]

For validation use Application.CheckSpelling (in opposite to range spelling, you can pass tested string directly and return True/False, so you can record only valid words).

combo

 

[mscallisto]

IMHO Macropod has the correct approach so far (almost)

First I believe you're looking for combinations (order doesn't matter) as opposed to permutations where (order matters)

Second I don't believe you can correctly use Len(strTest)factorial unless all the letters are different.

You may want to use (Len(strTest) - 1) for each letter that appears more than once.

e.g macro would 5! 5x4x3x2x1 vs macropod (two o's) would be 7!

Having said that, I'm still not convinced I'm right!!!!

 

[mscallisto]

for the above I should have said there can be two different "length" factors

1 if you choose to include all letters in strWord
2 if you choose to include only one of each letter in strWord.

I too like Scrabble and it would be fun to see if this works.

A similar fun site to visit is this "Anagram" generator.

http://wordsmith.org/anagram/advanced.html

try "tihel" to see it produces:

Eh Lit
He Lit
Let Hi

 

[strongm]

I think I'd take a very different approach, and do a bunch of the hard work up front.

I'd take a word list, such as SOWPODS (since people are talking Scrabble), take each word from it and serialise it (i.e sort the letters it contains in alphabetrical order; SPOON gives NOOPS); this acts as an index. Against that index I'd place all words from SOWPODS that produce that index when serialised (in our example that would be NOOPS, POONS, SNOOP, SPOON). This is the 'hard' work bit (pretty simple code, just a bit time-consuming), so I'd then save this so that I could load it directly in the future without having to recalculate it

So now, when a word is entered, I just serialise it, look up the index and return all the words held against that index, which will all be legitimate SOWPODS anagrams of that word. Extracting all the sub-words is also simplified by this approach

 

[strongm]

Which, just for fun, allowed me to generate this list of SOWPODS approved words that are anagrams of (or par of) 'descrambler':

de
ed
ee
el
bac
cab
dee
eel
lee
elm
mel
cede
dele
leed
leme
merl
lemed
medle
merel
merle
melder
belaced
debacle
becalmed
clambered
descrambler

 

[bdmangum]

Thanks for all the response guys! I have modifed macropod's Word macro to fit Excel and to grab all the sub words. The code is below. It works fine for words of length 3-5, beyond that the amount of calculations increases too quickly and the macro crashes.

Strongm,
Could you expound more on your approach? If I understand you correctly you would create an index using a macro which you would then load and cross-check based upon the inputted word?

If anyone has any other good methods, speak up. The code below works alright, however there has to be a better method.

Sub Permutations()
' Select a string, then run the macro
Dim strTest As String
Dim strOut, strVal, strChk As Boolean
Dim i As Long, j As Long, pos As Long, k As Long, l As Long, m As Long
strTest = LCase(InputBox("Input word or letters to be descrambled.", "Word Descrambler"))
strOut = Mid(strTest, 1, 1)
strOut = StringString(2, strOut & " ")
strOut = RTrim(strOut)
strChk = False

For j = 2 To Len(strTest)
    strOut = Split(strOut, " ")
    ' weave
    For i = 0 To UBound(strOut)
        pos = i Mod (2 * j)
        pos = pos - (j - 1)
        Select Case pos
        Case Is <= 0
            pos = Abs(pos)
        Case Else
            pos = pos - 1
        End Select
        strOut(i) = InsertString((strOut(i)), _
        Mid(strTest, j, 1), pos)
    Next i
    If j < Len(strTest) Then
        For i = 0 To UBound(strOut)
        strOut(i) = _
          StringString(j + 1, strOut(i) & " ")
        Next i
    End If
    strOut = Join(strOut, " ")
    strOut = Replace(strOut, "  ", " ")
    strOut = RTrim(strOut)
Next j
strOut = Split(strOut, " ")
For k = 0 To UBound(strOut)
    For l = 2 To Len(strOut(k))
        If Application.CheckSpelling(Left(strOut(k), l)) = True Then
            If strVal <> "" Then
                strVal = Split(strVal, ", ")
                For m = 0 To UBound(strVal)
                    If strVal(m) = Left(strOut(k), l) Then
                        strChk = True
                        Exit For
                    End If
                Next m
                strVal = Join(strVal, ", ")
                strVal = Replace(strVal, "  ", " ")
                strVal = RTrim(strVal)
                If strChk = False Then strVal = strVal + ", " + Left(strOut(k), l)
                strChk = False
            Else
                strVal = Left(strOut(k), l)
            End If
        End If
    Next l
Next k
strOut = Join(strOut, " ")
strOut = Replace(strOut, "  ", " ")
strOut = RTrim(strOut)

MsgBox "Valid words created from given letters are listed below:" & vbLf & vbLf & strVal

End Sub
Function InsertString(strOld As String, strInsert As String, pos As Long) As String
' Inserts strInsert into strOld at position pos
InsertString = Left(strOld, pos) & strInsert & Mid(strOld, pos + 1)
End Function
Function StringString(imax As Long, myString As String) As String
' Comparable to String(). Creates string of imax times the string myString
Dim i As Long
If imax < 0 Then MsgBox "imax < 0", vbCritical
i = 0
StringString = ""
Do While i < imax
    Select Case i
    Case 0, Is >= imax / 2
        StringString = StringString & myString
        i = i + 1
    Case Else
        StringString = StringString & StringString
        i = 2 * i
    End Select
Loop
End Function

 

[macropod]

Hi bdmangum,

I haven't reviewed you code, but the code I posted didn't crash on longer strings, it just took a long time. To deal with this, you could put a progress counter on the status bar - just to let the user know it's still working.

Cheers

[MS MVP - Word]

 

[bdmangum]

Macropod,

I thought about putting in a progress bar, but never did. I usually run the macro on XP, but the above macro was crashing when I used Vista. I just ran it on XP and it seemed to run alright for the longer strings, it just took a long time.