Porgramme to Solve the words in a set of jumbled Alphabets

programme to get valid words from jumbled letters

I had created this program while playing text games on BING so that I can quickly solve puzzles and earn points... lost the lust after sometime. But searched a lot on Internet at that time and did not find it. I found that hub users may be interested....

take it into word VBA macro and run "my trained script"

provide the jumbled letters from Bing text game...

It would generate all valid combinations for 3,4, 5, 6 and 7 letter words and write on the page. solve your text puzzles fast... Did not get time to clean.. but it works.. the more letter you give and more time it takes... try up to 7 letters.. it takes about 30 - 50 seconds.

enjoy!

 

Recursive program for generating all words for given letters

Public myWords() As String
Public wordCount As Integer
Public xx As Long
Public expString As Words
Public scrambDict As New Scripting.Dictionary
Public Sub myTrainedScript()

Dim word As String
Dim strcombis As String
Dim l, pos, c
Dim myStrs() As String * 1
Dim wordLen As Integer
Dim mlen, posx
Dim loopWord
xx = 0

wordCount = 0
ReDim myWords(wordCount) As String


word = InputBox("Please give me letters", "Ask Letters")
word = sortStr(word)
wordLen = Len(word)
ReDim myStrs(wordLen) As String * 1

For l = 1 To wordLen
  myStrs(l) = Mid(word, l, 1)
Next
strCombi word
elimOnePos word, 3
scrambDict.RemoveAll

Debug.Print xx

wordCount = UBound(myWords)

If wordCount = 0 Then Exit Sub

For i = 1 To wordCount
  For j = i + 1 To wordCount
  If myWords(i) > myWords(j) Then
    temp = myWords(i)
    myWords(i) = myWords(j)
    myWords(j) = temp
  End If
 Next
Next

For i = 1 To wordCount
  For j = i + 1 To wordCount
    If Len(myWords(i)) > Len(myWords(j)) Then
      temp = myWords(i)
      myWords(i) = myWords(j)
      myWords(j) = temp
    End If
  Next
Next

mylen = Len(myWords(1))

For i = 1 To wordCount
  If myWords(i) <> myWords(i - 1) Then
  If Len(myWords(i)) = mylen Then
    ActiveDocument.Range.InsertAfter myWords(i) & ", "
  Else
  ActiveDocument.Range.InsertAfter Chr(13)
  ActiveDocument.Range.InsertAfter myWords(i) & ", "
  mylen = Len(myWords(i))
 End If
End If
Next
End Sub
Public Sub elimOnePos(srcStr, tgtLen)
Dim thisLen As Integer, thisLoopStr As String
thisLen = Len(srcStr)
For i = 1 To thisLen
 Select Case i
  Case 1
    thisLoopStr = Right(srcStr, thisLen - 1)
  Case thisLen
    thisLoopStr = Left(srcStr, thisLen - 1)
  Case Else
    thisLoopStr = Mid(srcStr, 1, i - 1) & Mid(srcStr, i + 1, thisLen - i)
  End Select
  thisLoopStr = sortStr(thisLoopStr)
  If Not (scrambDict.Exists(thisLoopStr)) Then
  scrambDict.Add thisLoopStr, thisLoopStr
  strCombi thisLoopStr
  If Len(thisLoopStr) <> tgtLen Then
  elimOnePos thisLoopStr, tgtLen
  End If
  End If
  xx = xx + 1
Next
End Sub


Sub strCombi(inputString As String) ' main program structure begins here
Dim seedinput As String * 1
Dim remainstrX As String
Dim chkchar As String * 1
Dim stringLength As Integer, i As Integer
Dim strs() As String * 1
stringLength = Len(inputString)
ReDim strs(stringLength) As String * 1
inputString = sortStr(inputString)
seedinput = ""
For i = 1 To stringLength
  strs(i) = Mid(inputString, i, 1)
Next
For i = 1 To stringLength
  If (strs(i) <> seedinput) Then
  seedinput = strs(i)
  Select Case i
  Case 1
  remainstrX = Right(inputString, stringLength - 1)
  Case stringLength
  remainstrX = Left(inputString, stringLength - 1)
  Case Else
  remainstrX = Mid(inputString, 1, i - 1) & Mid(inputString, i + 1, stringLength - i)
 End Select
  Call StrRecur(seedinput, Trim(remainstrX), 0, "@")
  End If
Next
End Sub


Sub StrRecur(instrX, mainstrX, cplace, cchar) ' this is a recursive subsroutine
Dim chklen As Integer, i As Integer
Dim seedStr As String, nxtstr As String
Dim nxtchar
Dim strsX() As String * 1


chklen = Len(mainstrX)
If (chklen = 1) Then
  seedStr = instrX & mainstrX
  GoTo myt20
End If
nxtchar = ""
ReDim strsX(chklen) As String * 1
For i = 1 To chklen
  strsX(i) = Mid(mainstrX, i, 1)
Next

For i = 1 To chklen
  If (nxtchar <> strsX(i)) Then
  nxtchar = strsX(i)
  seedStr = instrX & nxtchar
  Select Case i
  Case 1
  nxtstr = Mid(mainstrX, i + 1, chklen - i)
  Case chklen
  nxtstr = Mid(mainstrX, 1, i - 1)
  Case Else
  nxtstr = Mid(mainstrX, 1, i - 1) & Mid(mainstrX, i + 1, chklen - i)
 End Select
  Call StrRecur(Trim(seedStr), Trim(nxtstr), cplace, cchar)
  End If
Next
GoTo myt30
myt20: If (cplace <> 0) Then
  If (Mid(seedStr, cplace1) = cchar) Then
  If Application.CheckSpelling(seedStr) Then
  ActiveDocument.Paragraphs.Add (seedStr)
  End If
End If
  Else
  If Application.CheckSpelling(seedStr) Then
  wordCount = wordCount + 1
  ReDim Preserve myWords(wordCount) As String
  myWords(wordCount) = seedStr
  End If
 End If
myt30: xxd = 0
End Sub

Function sortStr(instrX) As String
Dim temp As String * 1
Dim strLen As Integer
Dim strs() As String * 1

strLen = Len(instrX)
ReDim strs(strLen) As String * 1

For i = 1 To strLen
  strs(i) = Mid(instrX, i, 1)
Next

For i = 1 To strLen - 1
  For j = (i + 1) To strLen
  If (strs(i) > strs(j)) Then
 temp = strs(i)
  strs(i) = strs(j)
  strs(j) = temp
  End If
  Next
Next

sortStr = ""

For i = 1 To strLen
 sortStr = sortStr & strs(i)
Next

End Function

More by this Author


Comments 3 comments

yamanote profile image

yamanote 7 years ago from UK/Spain

i hadnt used the word VBA macro before, thanks


HubChief profile image

HubChief 7 years ago from United States Author

that is helpful. I can add a hub for how to use VBA and what are its uses if someone has not done that yet. Do you think If I made an EXE would help?


Vishal 5 years ago

Hello There,

it would be great if someone help with how to rap this into excel ?

Cheers,

Vishal.

    Sign in or sign up and post using a HubPages Network account.

    0 of 8192 characters used
    Post Comment

    No HTML is allowed in comments, but URLs will be hyperlinked. Comments are not for promoting your articles or other sites.


    Click to Rate This Article
    working