CODEWITHSUNDEEP
vbaexcel
Fly Guy
Fly Guy

Reputation: 265

Randomize word in VBA

I need to write a vba code that would give me all the letter combinations of a word and save it into a text file (this code is optional). For, instance, the word 'aBc' would return:

aBc
acB
Bac
Bca
caB
cBa

I'm sure it's an easy code but I can't seem to figure it out.

Here's the code I have so far. It keeps giving me duplicates and not all the results.

Sub Scramble()
Dim Rand1()
a = Len(Range("a2").Value)
ReDim Rand1(a)
T = 0
Randomize
For n = 1 To a
  Check1:
  Rand1(n) = Int((a * Rnd(100)) + 1)
  For F = 1 To T
    If Rand1(n) = Rand1(F) Then GoTo Check1:
  Next F
  T = T + 1   
Next n

For s = 2 To 20
  Range("d" & s).ClearContents
  n = 1
  Rand1(n) = Int((a * Rnd(100)) + 1)
    For n = 1 To a
      Range("d" & s).Value = Range("d" & s).Value & Mid(Range("a2").Value, Rand1(n), 1)
    Next n
Next s

End Sub

Upvotes: 1

Views: 1104

Answers (1)

John Coleman
John Coleman

Reputation: 51998

A recursive approach is natural. To scramble e.g. "MATH" you pull the letters out one at a time, scramble the remaining letters, then insert the pulled out letter in the front. Using memoization, something like this:

'Assumes that all letters are distinct

Dim Memory As Object

Function Helper(s As String, Optional delim As String = ",") As String
    Dim i As Long, n As Long
    Dim t As String, c As String
    Dim A As Variant

    If Memory.exists(s) Then
        Helper = Memory(s)
        Exit Function
    End If

    'otherwise:
    'Check Basis Case:

    If Len(s) <= 1 Then
        Helper = s
    Else
        n = Len(s)
        ReDim A(1 To n)
        For i = 1 To n
            c = Mid(s, i, 1)
            t = Replace(s, c, "")
            A(i) = Helper(t, delim)
            A(i) = c & Replace(A(i), delim, delim & c)
        Next i
        Helper = Join(A, delim)
    End If

    'record before returning:

    Memory.Add s, Helper
End Function

Function Scramble(s As String, Optional delim As String = ",") As String
    Set Memory = CreateObject("Scripting.dictionary")
    Scramble = Helper(s, delim)
    Set Memory = Nothing
End Function

Sub Test()
    Dim s As String
    Dim i As Long, n As Long
    Dim A As Variant

    s = "MATH"
    A = Split(Scramble(s), ",")
    For i = 0 To UBound(A)
        Cells(i + 1, 1).Value = A(i)
    Next i
End Sub

After running this, column A looks like:

MATH
MAHT
MTAH
MTHA
MHAT
MHTA
AMTH
AMHT
ATMH
ATHM
AHMT
AHTM
TMAH
TMHA
TAMH
TAHM
THMA
THAM
HMAT
HMTA
HAMT
HATM
HTMA
HTAM

Upvotes: 2

Related Questions