Randomize word in VBA

Question

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

As you know by now, SO is not a free code-writing service. Yet, we are eager to help fellow programmers (and aspirants) with their code. Please read the HELP topics for [How do I Ask a Good Question](http://stackoverflow.com/help/how-to-ask). Afterwards, please update your question with the VBA code you have written thus far in order to complete the tasks you wish to achieve. If you're merely wondering about the logic to do what you asked for then you might want to have a look at this: http://stackoverflow.com/questions/127704/algorithm-to-return-all-combinations-of-k-elements-from-n — Ralph, Apr 11 '16 at 19:34

score 2 · Accepted Answer · answered Apr 11 '16 at 22:05

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

Randomize word in VBA

1 Answers1

Linked