Create Anagrams Using VBA In Excel 3

[PBAPaul]

I sat down to write a macro in Excel to create anagrams of an entered word or phrase.

After quite a bit of code, I had got nowhere. Has anyone got any ideas?

Thanks

Paul

 

[Loomah]

Paul
Are you expecting to get anagrams that make sense or just the letters of a word rearranged randomly?

Spooky coincidence that I was thinking if something like this was possible so now I may get my aig and have a look at this.

Will get back if I come up with anything but have to go out now.
;-)

If a man says something and there are no women there to hear him, is he still wrong?
The faqs ma'am, just the faqs. Get the best from these forums : faq222-2244

 

[VBAjedi]

I would try the following:

Load the word into an array
Systematically rearrange the letters in new combinations (using the array index), and check each new combination with the spellchecker as follows:

x = Application.CheckSpelling(LettersString)
If x = True Then
  ' Add LettersString to list of acceptable words
End If

Obviously trying to do whole phrases will be much more difficult - you can write code to create possible words, and probably even to return only those word sets that use all of the letters, but combining them into a phrase that makes sense will probably have to be a manual step.


VBAjedi

 

[Loomah]

Hi again
Well, that was a bit of fun! I made the assumption that the resulting word doesn't need to make sense. Thing with this is that I can't think of a way to get back to the original text from the jumbled text.

Really strange effects with phrases - different length words and different spaces (though still had same num of spaces!)

Sub AnagramOfSorts()
Dim iLenNew As Integer
Dim strOldWord As String
Dim strNewWord As String
Dim iChar As Integer

'assign original text
strOldWord = Range("A1")

Do While Len(strOldWord) > 0
Randomize
    'select a character from old text to add to new text
    iChar = Int(Rnd() * Len(strOldWord)) + 1
    strNewWord = strNewWord + Mid(strOldWord, iChar, 1)
    
    'recreate old text without characters already added to new text
    strOldWord = Left(strOldWord, (iChar) - 1) + _
        Right(strOldWord, Len(strOldWord) - iChar)
Loop
'output the "mixed" text
Range("A2") = strNewWord
End Sub

Like I said this is something I'd considered before as a follow on from creating a routine to transpose a string.

Enjoy
;-)

If a man says something and there are no women there to hear him, is he still wrong?
The faqs ma'am, just the faqs. Get the best from these forums : faq222-2244

 

[Zathras]

Here are some routines that will generate all possible permutations of an input word. Note that if the same letter appears more than once in the word the same permutation will appear more than once as well.
[blue]

Option Explicit
Const GET_FIRST As Boolean = True

Sub test()
Dim sAnagram As String
  sAnagram = "TURKEY"
  Call Anagram(sAnagram, GET_FIRST)
  MsgBox sAnagram
  While Anagram(sAnagram)
    If vbCancel = MsgBox(sAnagram + vbNewLine + vbNewLine + _
              " Continue?", vbOKCancel, "Anagram") Then
      Exit Sub
    End If
  Wend
End Sub

Function Anagram(AWord As String, _
         Optional FirstOrNext As Boolean = False) As Boolean
  If FirstOrNext = GET_FIRST Then
    Call SortLetters(AWord)
    Anagram = True
  Else
    Anagram = NextPermutation(AWord)
  End If
End Function

Private Sub SortLetters(AWord)
Dim i As Integer
Dim j As Integer
Dim s As String
  For i = 1 To Len(AWord) - 1
    For j = i + 1 To Len(AWord)
      If Mid(AWord, i, 1) > Mid(AWord, j, 1) Then
        s = Mid(AWord, i, 1)
        Mid(AWord, i, 1) = Mid(AWord, j, 1)
        Mid(AWord, j, 1) = s
      End If
    Next j
  Next i
End Sub

Private Function NextPermutation(AWord As String) As Boolean

[green]

' Algorithm: Working from right to left, find the "critical"
' position.  The "critical" position is the first letter that
' is lower in sort order than the one at its right.
' Exchange the "critical" position character with the
' smallest one from the letters to the right of it that is
' larger than the "critical" letter.  Then sort all letters
' to the right of the "critical" letter in ascending order.
' If no "critical" position is found, return False.

[/color]

Dim i As Integer
Dim pCrit As Integer
Dim pSmallest As Integer
Dim sSmallest As String
Dim sCrit As String
Dim sLeft As String
Dim sRight As String

[green]

  ' Find "critical" position

[/color]

  For i = Len(AWord) To 2 Step -1
    If Mid(AWord, i - 1, 1) < Mid(AWord, i, 1) Then
      pCrit = i - 1
      Exit For
    End If
  Next i
  If pCrit = 0 Then
    NextPermutation = False
  Else

[green]

    ' Find smallest letter larger than critical

[/color]

    sSmallest = "z"
    sCrit = Mid(AWord, pCrit, 1)
    For i = pCrit + 1 To Len(AWord)
      If Mid(AWord, i, 1) > sCrit Then
        If Mid(AWord, i, 1) < sSmallest Then
          pSmallest = i
          sSmallest = Mid(AWord, pSmallest, 1)
        End If
      End If
    Next i

[green]

    ' Swap with critical

[/color]

    Mid(AWord, pCrit, 1) = sSmallest
    Mid(AWord, pSmallest, 1) = sCrit

[green]

    ' Sort remaining letters

[/color]

    sLeft = Mid(AWord, 1, pCrit)
    sRight = Mid(AWord, pCrit + 1)
    Call SortLetters(sRight)
    AWord = sLeft + sRight
    NextPermutation = True
  End If
End Function

[/color]

 

[PBAPaul]

WOW! I think I hit on a subject that interested lots of people.

Thanks to VBAjedi for the suggestion.

Thanks to Loomah for your interest and assistance.

Particular thanks to Zathras for the code.

I will now go off and create anagrams galore!

Regards

Paul

 

[mscallisto]

Ok Loomah give me the faqs

Please explain strOldWord = Range("A1&quot

I can see that strOldWord is the string "cat" if "cat" is in A1 but explain the range("A1&quot part please.

 

[Stretchwickster]

On behalf of Loomah, I will answer your question mscallisto. Loomah is using the cells A1 as a quick and easy way of getting user input into the routine.

Clive

http://www.kucu.co.uk

Ex nihilo, nihil fit (Out of nothing, nothing comes)