Help Making Modified Permutation Code Run Faster

[Bearcat Brew]

Do you know the word game where you have to form as many words as you can with four or more letters by using the letters of a big word given to you? Well, I am trying to write a program in Excel that does this. In several places in the forum, I found some code from Myrna Larson that finds permutations and combinations. I have modified it to find the permutations of the letters in the given word. The original code's operation depended on the user putting a "C" or "P" (combinations or permutations) in A1, the number of choices to make out of the set in A2, and the set listed down column A starting in A3. I don't need combinations (order of the letters in making a new word matter) so the C/P option was eliminated. I also want all words four letters or longer that can be made from the given word, so I took code out that looked at Cell A2 and replaced it with a loop going from four to the total number of letters in the given word. Then instead of listing the set of letters down column A, I just put the whole word in one cell and wrote some new code that creates the set. Last, each possible permutation of the letters is checked against the dictionary and if the letters formed a word that is in the dictionary, it is added to a buffer array.

So far all of this works fine. Next issue to tackle was for the list to be created not to have duplicate entries. For example, from the word "dreamer", the word "dear" would appear four times (once with the first "e" and first "r", once with the second "e" and first "r", once with the first "e" and second "r", and once with the second "e" and second "r"). I can't just ignore duplicate letters when creating the set of available letters since I can create words using that letter as many times as it appears in the given word (for example, I could use both r's to spell "rear"). I got around this by checking each new created word against the buffer array and I do not add it if it is already in there. This also works fine, but herein lies the problem. Finding all of these permutations is very time consuming. For example, if an 11 letter word is given, 108,504,000 permutations of 4 through 11 letters are being checked. The section of code that creates each permutation loops a few times so it is lengthy. I figured the best way to make this run faster would be to cut out the creation of duplicate words instead of having them create then check against the buffer array only to find they exist already. If some one could help me with this, I would appreciate it. Also, I would appreciate any other suggestions for modifications to make this run more efficiently. If not, I guess I will just have to let this run over night (or over the weekend for really big words). Anyway, this a pretty cool application of some existing code to solve a common puzzle.



Option Explicit

Dim AllItems() As String
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
Dim Counter As Long
'
' Myrna Larson, July 25, 2000, Microsoft.Public.Excel.Misc
' Modified by Mark Brzezinski, December 15, 2005

Sub ListPermutations()
Dim Rng As Range
Dim PopSize As Integer
Dim SetSize As Integer
Dim Which As String
Dim n As Double
Dim a As Integer
Dim Word As String
Dim WordNoSpc As String
Dim LtrCnt As Integer
Dim WordLen As Integer
Dim CurLet As Integer
Const BufferSize As Long = 4096

Counter = 0
CurLet = 1
Word = Cells(1, 1).Value
WordLen = Len(Word)
For a = 1 To WordLen
If Mid(Word, a, 1) <> " " Then PopSize = PopSize + 1
Next
ReDim AllItems(1 To PopSize) As String
For a = 1 To PopSize
Do Until Mid(Word, CurLet, 1) <> " "
CurLet = CurLet + 1
Loop
AllItems(a) = Mid(Word, CurLet, 1)
CurLet = CurLet + 1
Next

If PopSize < 4 Then GoTo DataError

Application.ScreenUpdating = False

Set Results = Worksheets.Add
Results.Cells(1, 1).Value = "Words spelled with the letters in """ _
& Sheets("Sheet1").Cells(1, 1).Value & """"

For SetSize = 4 To PopSize
If SetSize = PopSize Then Counter = 1

n = Application.WorksheetFunction.Permut(PopSize, SetSize)

ReDim Buffer(1 To BufferSize) As String
BufferPtr = 0

AddPermutation PopSize, SetSize

Application.ScreenUpdating = True
Next
Exit Sub

DataError:
If n = 0 Then
Which = "Enter your data in a vertical range of at least 4 cells." _
& String$(2, 10) _
& "Top cell must contain the number of items in a subset, " _
& "the cells below are the values from which " _
& "the subset is to be chosen."

End If
MsgBox Which, vbOKOnly, "DATA ERROR"
Exit Sub

End Sub

Private Sub AddPermutation(Optional PopSize As Integer = 0, _
Optional SetSize As Integer = 0, _
Optional NextMember As Integer = 0)

Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Static Used() As Integer
Dim i As Integer

If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
ReDim Used(1 To iPopSize) As Integer
NextMember = 1
End If

For i = 1 To iPopSize
If Used(i) = 0 Then
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
Used(i) = True
AddPermutation , , NextMember + 1
Used(i) = False
Else
SavePermutation SetMembers()
End If
End If
Next i

If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
Erase Used
End If

End Sub 'AddPermutation

Private Sub SavePermutation(ItemsChosen() As Integer, _
Optional FlushBuffer As Boolean = False)

Dim i As Integer, RepeatChk As Integer, x As Integer, sValue As String
Static RowNum As Long, ColNum As Long

If RowNum = 0 Then RowNum = 2
If ColNum = 0 Then ColNum = 1

If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
If BufferPtr > 0 Then
If (RowNum + BufferPtr - 1) > Rows.Count Then
RowNum = 2
ColNum = ColNum + 1
If ColNum > 256 Then Exit Sub
End If

Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _
= Application.WorksheetFunction.Transpose(Buffer())
RowNum = RowNum + BufferPtr
End If

BufferPtr = 0
If FlushBuffer = True Then
Erase Buffer
If Counter = 1 Then
RowNum = 0
ColNum = 0
End If
Exit Sub
Else
ReDim Buffer(1 To UBound(Buffer))
End If

End If

'construct the next set
For i = 1 To UBound(ItemsChosen)
x = ItemsChosen(i)
sValue = sValue & AllItems(x)
Next i

If Application.CheckSpelling(sValue) = True Then
'check if word already exists in buffer
RepeatChk = 1
If BufferPtr > 0 Then
Do Until RepeatChk = BufferPtr Or Buffer(RepeatChk) = sValue
RepeatChk = RepeatChk + 1
Loop
End If
If Buffer(RepeatChk) <> sValue Then
'save it in the buffer
BufferPtr = BufferPtr + 1
Buffer(BufferPtr) = sValue
End If
End If

End Sub 'SavePermutation

 

[al_b_cnu]

Hi,

I approached this by searching word lists for matches, which usually takes < 5 mins to complete.

Cant remember where I got the word lists originally, but think it was from this site: http://wordlist.sourceforge.net/

Email me & I'll send you my wordsearch.xls s/sheet.

 

[Seti]

Rather than sorting out duplicates while running, why not use the advanced filter once you are done and filter out unique results? You could overlay these results on the originals once you are done.

As a test, I ran dreamer thru your code with and without checking for duplicates. It ran in 9 vs 10 seconds so that is adding about 10% additional time. If I had to guess, I'd say the real drag on performance is the spell checking.

 

[Bearcat Brew]

Seti,

My first pass through this, I did have the duplicates showing in the list and got rid of them later. I knew the current duplicate check of the buffer array is slowing performance a bit, but I didn't think adding it would be a big drag compared to the spell checking, because you are right, the spell checking is where it slows down. What I really want to do is find a way to identify a duplicate and skip over it before it gets to the spell check. I know I can't store all of the incorrect word permutations and check against them (I assume that would be horribly slow).