Permutations

[Don Wells]

I want to develop some VBA code which will take a string of n unique characters found in cell A1 and in the subsequent cells of column A generate all permutations of cell A1 taken n characters at a time. Any thoughts?

TIA

[HansV]

I adapated some code from John Walkenbach for your purpose:

Code: Select all

Dim CurrentRow As Long

Sub GetString()
    Dim lngMax As Long
    Dim InString As String
    If Val(Application.Version) > 11 Then
      lngMax = 9
    Else
      lngMax = 8
    End If
    InString = Cells(1, 1)
    If Len(InString) < 2 Then Exit Sub
    
    If Len(InString) > lngMax Then
        MsgBox "Too many permutations!", vbExclamation
        Exit Sub
    Else
        Range(Cells(2, 1), Cells(Rows.Count, 1)).ClearContents
        CurrentRow = 1
        Call GetPermutation("", InString)
    End If
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)
    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

Source: Excel Developer Tip: Generating Permutations.

[Don Wells]

Thank you Hans. Exactly what I wanted. I can now amuse myself for some time to come trying to fathom the mechanics of the code.

[Don Wells]

I adapated some code from John Walkenbach for your purpose:
Source: Excel Developer Tip: Generating Permutations.

Thanks again Hans.

I have further adapted it to allow the maximum size of string whose permutations will fit on a worksheet (for those with the time to spare waiting for the calculations to finish). I would appreciate any critique of the code modification.
Edited to include the code. Oops!

Code: Select all

    Dim cp As Long ' Currrent Permutation
    Dim lr As Long ' Last Row

    Sub GetString()
        Dim lngMax As Long
        Dim InString As String
        If Val(Application.Version) > 11 Then
          lngMax = 15 ' Largest factorial which fits into _
                        1,048,576 rows and 16,384 columns
          lr = 1048576
        Else
          lngMax = 10 ' Largest factorial which fits into _
                        65,536 rows and 256 columns
          lr = 65536
        End If
        InString = Cells(1, 1)
        If Len(InString) < 2 Then Exit Sub
       
        If Len(InString) > lngMax Then
            MsgBox "Too many permutations!", vbExclamation
            Exit Sub
        Else
            Cells.ClearContents
            cp = 1
            Call GetPermutation("", InString)
        End If
    End Sub

    Sub GetPermutation(x As String, y As String)
    '   The source of this algorithm is unknown
        Dim i As Integer, j As Integer
        Dim cc As Long ' Current Column
        Dim cr As Long ' Current Row
        j = Len(y)
        If j < 2 Then
          cc = Int(cp / (lr)) + 1
          If cp Mod lr = 0 Then cc = cc - 1
          cr = cp Mod lr
          If cr = 0 Then cr = lr
            Cells(cr, cc) = x & y
            cp = cp + 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

[HansV]

It appears to work OK in a quick test!