permutations checkspelling speed

erik.van.geit

MrExcel MVP
Joined
Feb 1, 2003
Messages
17,832
Hi, guys and galls,
this is one for the gurus :-)

A1 has some characters
this code will generate all possible words, that can be made using all characters

system
permutate and checkspelling: if OK then write to column B

example
A1: iftrs
results: first frits rifts
Code:
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

any tricks to enhance the speed ?
thank you for reading :-)

kind regards,
Erik
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Hello Eric,


I am by no means a guru, and honestly I have no idea how to make your code any faster.

That being said, I did take a look at it and it is pretty interesting. One thing I wanted to point out to you in case you weren't aware of it is that whenever there is a duplicate letter, your code will return multiple instances of all words.

For example:

A1= lexce, will return B1=excel and C1=excel


You may already be aware of this, but I figured I would point it out in case you weren't.


Have a nice day. :)
 
Upvote 0
thank you for taking the time to get this post out of the unanswered list
yes, the problem was known to me, but is not relevant for this question
honestly I'm quite embarassed how to react, sorry

the question was about SPEED
I know it's a difficult one, at least for me

best regards,
Erik
 
Upvote 0
No need to be embarassed Eric. :)

I did understand your original question, however unfortunately I did not have a suggestion as to how to speed up your code.

With that being said, it is possible that by determining a way to handle duplicate letters you could improve the speed of the code.

For example, the letters bagegar entered in cell A1 returns the word garbage 4 separate times. Once you have checked for the letter g as the first letter one time, there is no need to do the second check. I'm not sure what would be the best way to do this, as I haven't taken the time to dissect your code yet, but this could be one way to reduce the speed.


Anyhow, I hope someone else can provide some more useful suggestions. I'm interested to see how this code can be improved.
 
Upvote 0
Hello Erik,

No Gurus comming up yet.
They must have overlooked.

I am still interested and hopeful.

Have a nice weekend.

Kind regards,
Luc
 
Upvote 0
This one is very fast :

Dim CurrentRow

Sub GetString()
Dim InString As String
InString = InputBox("Enter text to permute:")
If Len(InString) < 2 Then Exit Sub
If Len(S) >= 8 Then
MsgBox "Too many permutations!"
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
 
Upvote 0
Hi Erik

I experimented with 7 character strings and saved the character combinations into an array (of 500 items) and once the array was full I tested the spelling of all 500 items in one go. For all that effort I saved 1 second on a 7 character string - maybe there would be more significant savings on larger strings but it's late here and I will test it tomorrow....

That's quite a nifty algorithm nonetheless. Can you not remember where you got it from?

Cheers, Andrew
 
Upvote 0
Hi, guys and galls,
this is one for the gurus :-)

A1 has some characters
this code will generate all possible words, that can be made using all characters

system
permutate and checkspelling: if OK then write to column B

example
A1: iftrs
results: first frits rifts
Code:
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

any tricks to enhance the speed ?
thank you for reading :-)

kind regards,
Erik


As it has been years (decades?) since I earned bread as a programmer, feel free to ignore (laugh?) at my input: Would it be faster if you did not use GetPermuation recursively?
 
Upvote 0
Erik,
I believe the slow part is the .CheckSpelling Method itself. The possible time saved by adding results to an Array or Collection before writing to the sheet is almost trivial compared to how long it takes to check the spelling of each permutation. I ran this code, which checks the spelling but does not do anything if the permutation is an actual word. I then ran the code on 2,3,4,5,6,7, and 8 character words.


Code:
Dim myStart, myFinish As Double
 myStart = Now
 For i = 1 To Application.WorksheetFunction.Fact(Len(Range("A1").Value))
    If Application.CheckSpelling(Range("A1").Value) Then
       ' Do Nothing
    End If
 Next i
 myFinish = Now
 iRow = Range("D65535").End(xlUp).Row + 1
 Cells(iRow, 4).Value = Range("A1").Value
 Cells(iRow, 5).Value = myFinish - myStart
 Cells(iRow, 6).Value = Application.WorksheetFunction.Fact(Len(Range("A1").Value))

Here are my results:
Book1
DEFG
1StringCalc TimePermutations
2AB0:00.0002
3AB0:00.0002
4ABC0:00.0006
5ABCD0:00.00024
6ABCDE0:00.000120
7ABCDEF0:02.000720
8ABCDEFG0:10.0005040
9ABCDEFGH1:17.00040320
Sheet1


As you can see, by the time you get up to 8 characters it take my machine over a minute to check the 40,320 possibilities.

This isn't really my area of expertise, so I'm not sure how I can access the Main Dictionary. I was wondering if it would be possible to write all the entries in the Main Dictionary to a Spreadsheet. (I know it would huge 65,535 rows x Many Columns). Would an Index(Match) applied to this range be any faster?
 
Upvote 0

Forum statistics

Threads
1,223,236
Messages
6,170,917
Members
452,366
Latest member
TePunaBloke

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top