Bearcat Brew
New Member
- Joined
- Dec 7, 2004
- Messages
- 40
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
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