Permutation List in Excel - selection from n items

[kstatinet]

Hi,

Need your help with Excel to create a permutation list:

1. Let say there are 5 buttons (e.g. A B C D E) and 3 are pressed and each separately. For any single combination, none of the selected buttons can be repeated. I should get 60 unique combinations ( 5 1 ) * ( 4 1 ) * ( 3 1 ) = 60
With a total of 5 buttons and 3 buttons pressed, the unique combination can be:
1) A B C
2) C B A
3) D A C
4) C D A
5) A D C
...
60) BAC

2) Let say there are 5 buttons (e.g. A B C D E) and 4 buttons are pressed (2 separately and 2 other buttons together) there should be 180 unique combinations: 3 * ( 5 1 ) * ( 4 1 ) * ( 3 2 ) . None of the buttons can be pressed more than once.

 

[mikerickson]

You could use this. It involves Class modules.
Create a class Module and name it clsTransposition and put this code in it.

' in clsTransposition

Dim pHigh As Long
Dim pLow As Long

Sub ActOn(ByRef anArray As Variant)
    Dim lowIndex As Long
    Dim highIndex As Long
    Dim temp As Variant
    lowIndex = pLow + LBound(anArray) - 1
    highIndex = pHigh + LBound(anArray) - 1
    Rem test for sizing
    If UBound(anArray) < highIndex Then
        Err.Raise vbObjectError + 530, Description:="array to small for this transpose"
    End If
 
    temp = anArray(lowIndex)
    anArray(lowIndex) = anArray(highIndex)
    anArray(highIndex) = temp
End Sub

Function ActingOn(ByVal someArray As Variant) As Variant
        Dim anArray As Variant
        anArray = someArray
        Me.ActOn anArray
        ActingOn = anArray
End Function

Property Get Display() As String
    Display = "(" & pLow & ", " & pHigh & ")"
End Property

Property Get High() As Long
    High = pHigh
End Property

Property Get Low() As Long
    Low = pLow
End Property

Function SetValue(inLow As Long, inHigh As Long) As clsTransposition
    If inLow < inHigh Then
        pLow = inLow
        pHigh = inHigh
    ElseIf inLow = inHigh Then
        pLow = 1
        pHigh = 1
    Else
        pHigh = inLow
        pLow = inHigh
    End If
    Set SetValue = Me
End Function

Private Sub Class_Initialize()
    pLow = 1
    pHigh = 1
End Sub

The create another class module, name clsPermutation and with this code

' in clsPermutation

Public Transpositions As Collection

Sub ActOn(ByRef anArray As Variant)
    Dim i As Long
    For i = 2 To Transpositions.Count
        Transpositions(i).ActOn anArray
    Next i
End Sub

Function ActingOn(ByVal anArray As Variant)
    Dim Result As Variant
    Result = anArray
    Me.ActOn Result
    ActingOn = Result
End Function

Function AndThen(aPerm As clsPermuation) As clsPermuation
    Dim Size As Long
    Dim arrNull As Variant, arrResult As Variant
    Dim Result As clsPermuation
 
    Size = WorksheetFunction.Max(aPerm.Level, Me.Transpositions(Me.Transpositions.Count).High)
 
    arrNull = OneTo(Size)
    arrResult = Me.ActingOn(arrNull)
 
    aPerm.ActOn arrResult
    Set Result = New clsPermuation
    Result.GetFromArray arrResult, arrNull
    Set AndThen = Result
    Set Result = Nothing
End Function

Function AndThenOther(aPerm As clsPermuation) As clsPermuation
    Dim Result As clsPermuation
    Dim xTrans As clsTransposition
    Dim arrTrans() As clsTransposition
    Dim upTrans As clsTransposition, downTrans As clsTransposition
    Dim i As Long, tPointer As Long, tLookAt As Long, j As Long
 
    ReDim arrTrans(1 To Me.Transpositions.Count + aPerm.Transpositions.Count)
    For i = 1 To Me.Transpositions.Count
        Set xTrans = New clsTransposition
        tPointer = tPointer + 1
        Set arrTrans(tPointer) = xTrans.SetValue(Me.Transpositions(i).Low, Me.Transpositions(i).High)
    Next i
 
    For i = 2 To aPerm.Transpositions.Count
        Set xTrans = New clsTransposition
        Set xTrans = New clsTransposition
        tPointer = tPointer + 1
        Set arrTrans(tPointer) = xTrans.SetValue(aPerm.Transpositions(i).Low, aPerm.Transpositions(i).High)
     
        ' shift trans to positions
        tLookAt = tPointer
        Do
            Set upTrans = arrTrans(tLookAt)
            Set downTrans = arrTrans(tLookAt - 1)
         
            If upTrans.High > downTrans.High Then
                Exit Do
            End If
         
            If upTrans.High <> downTrans.High And upTrans.High <> downTrans.Low _
                And upTrans.Low <> downTrans.High And upTrans.Low <> downTrans.Low Then
                Set xTrans = arrTrans(tLookAt)
                Set arrTrans(tLookAt) = arrTrans(tLookAt - 1)
                Set arrTrans(tLookAt - 1) = xTrans
                tLookAt = tLookAt - 1
            ElseIf upTrans.High = downTrans.High Then
                If upTrans.Low = downTrans.Low Then
                    For j = tLookAt + 1 To tPointer
                        Set arrTrans(i - 2) = arrTrans(i)
                    Next j
                    tPointer = tPointer - 2
                    Exit Do
               Else
                    j = downTrans.Low
                    downTrans.SetValue downTrans.Low, upTrans.Low
                    upTrans.SetValue upTrans.High, j
                    Set arrTrans(tLookAt) = upTrans
                    Set arrTrans(tLookAt - 1) = downTrans
                    tLookAt = tLookAt - 1
                End If
             
            Else
                'downtrans.high>uptrans.high
                If upTrans.High = downTrans.Low Then
             
                ElseIf upTrans.Low = downTrans.Low Then
                
                End If
         
            End If
         
        Loop While tLookAt > 1
    Next i
 
    Set Result = New clsPermuation
    For i = 2 To tPointer
        If Not (arrTrans(i) Is Nothing) Then
            Result.Transpositions.Add Item:=arrTrans(i)
        End If
    Next i
 
    Set AndThenOther = Result
    Set Result = Nothing
    Set xTrans = Nothing
End Function


Property Get Display(Optional WithNull) As String
    Dim i As Long
    For i = 1 To Transpositions.Count
        Display = Display & Transpositions(i).Display
    Next i
End Property

Sub GetFromArray(ByRef PermutedArray As Variant, Optional Alphabet As Variant)
    Dim i As Long, j As Long, temp As Variant
    Dim Size As Long
    Dim xTrans As clsTransposition
    Dim pPermutedArray As Variant, pAlphabet As Variant
 
    Size = UBound(PermutedArray) - LBound(PermutedArray) + 1

    If LBound(PermutedArray) = 1 Then
        pPermutedArray = PermutedArray
    Else
        ReDim pPermutedArray(1 To Size)
       j = UBound(PermutedArray) - UBound(pPermutedArray)
        For i = 1 To Size
            pPermutedArray(i) = PermutedArray(i + j)
        Next i
    End If
 
    If IsMissing(Alphabet) Then
        pAlphabet = OneTo(Size)
    ElseIf LBound(PermutedArray) = 1 Then
        pAlphabet = Alphabet
    Else
        ReDim pAlphabet(1 To Size)
        For i = 1 To Size
            pAlphabet(i) = Alphabet(i + j)
        Next i
    End If
 
    For i = Size To 2 Step -1
        If pPermutedArray(i) <> pAlphabet(i) Then
            For j = 1 To i - 1
                If pPermutedArray(j) = pAlphabet(i) Then
                    Exit For
                End If
            Next j
         
            Set xTrans = New clsTransposition
            Transpositions.Add Item:=xTrans.SetValue(i, j), after:=1
            temp = pPermutedArray(i)
            pPermutedArray(i) = PermutedArray(j)
            pPermutedArray(j) = temp
        End If
    Next i
    Set xTrans = Nothing
End Sub

Function Inverse() As clsPermuation
    Dim Result As clsPermuation
    Dim arrNull As Variant, arrPermuted As Variant
    arrNull = OneTo(Me.Level)
 
    arrPermuted = Me.ActingOn(arrNull)
    Set Result = New clsPermuation
    Result.GetFromArray arrNull, arrPermuted
    Set Inverse = Result
    Set Result = Nothing
End Function

Property Get Level() As Long
    With Transpositions
        Level = .Item(.Count).High
    End With
End Property

Public Function NextPermutation() As clsPermuation
    Dim Result As clsPermuation
    Dim xTrans As clsTransposition
    Dim i As Long
 
    Set xTrans = New clsTransposition
 
    If Transpositions.Count = 1 Then
        Set Result = New clsPermuation
        Result.Transpositions.Add xTrans.SetValue(1, 2)
    Else
        Set Result = TruncatedPerm.NextPermutation
        With Me.Transpositions(Me.Transpositions.Count)
            If Result.Level < Me.Level Then
                Result.Transpositions.Add Item:=xTrans.SetValue(.Low, .High)
            Else
                If .High = .Low + 1 Then
                    Set Result = New clsPermuation
                    Result.Transpositions.Add Item:=xTrans.SetValue(1, .High + 1)
                Else
                    Set Result = New clsPermuation
                    Result.Transpositions.Add Item:=xTrans.SetValue(.Low + 1, .High)
                End If
            End If
        End With
    End If
 
    Set NextPermutation = Result
 
    Set Result = Nothing
    Set xTrans = Nothing
End Function

Function PreviousPerm() As clsPermuation
    Dim Result As clsPermuation
    Dim lastTrans As clsTransposition
    Dim xTrans As clsTransposition
    Dim i As Long
 
    Set lastTrans = Me.Transpositions(Me.Transpositions.Count)
 
    If Me.Transpositions.Count = 1 Then
        Rem error,return null
        Set Result = New clsPermuation
    ElseIf Me.Transpositions.Count = 2 Then
        Rem create zoop down
        Set Result = New clsPermuation
        For i = 2 To Me.Level - 1
            Set xTrans = New clsTransposition
            Result.Transpositions.Add Item:=xTrans.SetValue(i - 1, i)
        Next i
     
        With lastTrans
            If 1 < .Low Then
                Set xTrans = New clsTransposition
                Result.Transpositions.Add Item:=xTrans.SetValue(.Low - 1, .High)
            End If
        End With
    Else
        Rem truncatedPerm lastTrans
        Set Result = TruncatedPerm.PreviousPerm
        Set xTrans = New clsTransposition
        Result.Transpositions.Add Item:=xTrans.SetValue(lastTrans.Low, lastTrans.High)
    End If
 
    Set PreviousPerm = Result
 
    Set Result = Nothing
    Set lastTrans = Nothing
    Set xTrans = Nothing
End Function

Sub SetToTranspositions(inLow As Long, inHigh As Long)
    Dim xTrans As clsTransposition
    Set Transpositions = Nothing
    Set Transpositions = New Collection
    Set xTrans = New clsTransposition
    Transpositions.Add Item:=xTrans
    Set xTrans = New clsTransposition
    Transpositions.Add Item:=xTrans.SetValue(inLow, inHigh)
 
    Set xTrans = Nothing
End Sub

Property Get strOrder(Optional ByVal ShowSize As Long, Optional Delimiter As String = " ") As String
    Dim arrNull As Variant
    Dim i As Long
    ShowSize = WorksheetFunction.Max(Me.Level, ShowSize)
    ReDim arrNull(0 To ShowSize - 1)
    For i = 0 To UBound(arrNull): arrNull(i) = (i + 1): Next i
    Me.ActOn arrNull
    strOrder = Join(arrNull, Delimiter)
End Property
Private Function TruncatedPerm() As clsPermuation
    Dim Result As New clsPermuation
    Dim xTrans As clsTransposition
    Dim i As Long
 
    For i = 2 To Me.Transpositions.Count - 1
        Set xTrans = New clsTransposition
        With Me.Transpositions(i)
             Result.Transpositions.Add Item:=xTrans.SetValue(.Low, .High)
        End With
    Next i
    Set TruncatedPerm = Result
    Set Result = Nothing
    Set xTrans = Nothing
End Function

Private Sub Class_Initialize()
    Dim xTrans As clsTransposition
    Set Transpositions = New Collection
    Set xTrans = New clsTransposition
    Transpositions.Add Item:=xTrans
    Set xTrans = Nothing
End Sub

(clsPermuation has several properties and methods that aren't needed for this problem)

Then another class module, named clsChoice with this code

' in clsChoice

Option Base 1

Dim pChoiceArray() As Boolean

Property Get ActingOn(ByRef anArray As Variant) As Variant
    Dim i As Long, Pointer As Long
    Dim Result As Variant, oneElement As Variant
  
    ReDim Result(1 To UBound(pChoiceArray))
    For Each oneElement In anArray
        i = i + 1
        If UBound(pChoiceArray) < i Then Exit For
        If pChoiceArray(i) Then
            Pointer = Pointer + 1
            Result(Pointer) = oneElement
        End If
    Next oneElement
    ReDim Preserve Result(1 To Pointer)
    ActingOn = Result
End Property

Property Get ChoiceArray(Optional Index As Long) As Variant
    If Index < 1 Then
        ChoiceArray = pChoiceArray
    Else
        ChoiceArray = pChoiceArray(Index)
    End If
End Property
Property Let ChoiceArray(Optional Index As Long, inVal As Variant)
    Dim i As Long
    If Index < 1 Then
        ReDim pChoiceArray(1 To UBound(inVal))
        For i = 1 To UBound(inVal)
            pChoiceArray(i) = inVal(i)
        Next i
    Else
        pChoiceArray(Index) = inVal
    End If
End Property


Property Get ChooseK() As Long
    Dim i As Long
    For i = 1 To UBound(pChoiceArray)
        ChooseK = ChooseK - CLng(pChoiceArray(i))
    Next i
End Property
Property Let ChooseK(inVal As Long)
    Dim i As Long
    If inVal < 1 Then
        ReDim pChoiceArray(0 To 0)
    Else
        For i = 1 To UBound(pChoiceArray)
            pChoiceArray(i) = (k <= inVal)
        Next i
    End If
End Property

Property Get FromN(Optional Kval As Long) As Long
    FromN = UBound(pChoiceArray)
End Property
Property Let FromN(Optional Kval As Long, inN As Long)
    Dim i As Long
  
    If Kval < 1 Then
        Kval = Me.ChooseK
    End If
    If Kval = 0 Then
        Kval = inN
    Else
        Kval = WorksheetFunction.Min(inN, Kval)
    End If
  
    If inN < 0 Then
        Err.Raise vbObjectError + 600
    ElseIf inN = 0 Then
        ReDim pChoiceArray(0 To 0)
    Else
        ReDim pChoiceArray(1 To inN)
        For i = 1 To Kval
            pChoiceArray(i) = True
        Next i
    End If
End Property

Function NextChoice(Optional ByRef OverFlow As Boolean) As clsChoice
    Dim lookAt As Long, WriteTo As Long
    Dim arrResult As Variant
    Dim Result As clsChoice
  
    arrResult = pChoiceArray
    lookAt = 1
    Do Until arrResult(lookAt)
        lookAt = lookAt + 1
    Loop
  
    Do
        If arrResult(lookAt) Then
            WriteTo = WriteTo + 1
           
             arrResult(lookAt) = False
             arrResult(WriteTo) = True
             lookAt = lookAt + 1
        Else
            Rem done
            arrResult(WriteTo) = False
            arrResult(lookAt) = True
            Exit Do
        End If
    Loop Until UBound(arrResult) < lookAt
    OverFlow = (UBound(arrResult) < lookAt)
  
    Set Result = New clsChoice

    Result.ChoiceArray = arrResult
    Set NextChoice = Result
    Set Result = Nothing
End Function


Private Sub Class_Initialize()
    ReDim pChoiceArray(0 To 0)
End Sub

Then in a normal module, this will do what you want. Adjust the destinationSheet to your situation.

' in a normal module

Sub Test()
    Dim Choice As clsChoice, choiceFlag As Boolean
    Dim Permutation As clsPermuation, permFlag As Boolean
    Dim thisArray As Variant
    Set Permutation = New clsPermuation
    Set Choice = New clsChoice
    Dim BaseArray As Variant
    Dim ChosenArray As Variant
    Dim HowMany As Long, chooseHowMany As Long, i As Long
    Dim DestinationSheet As Worksheet

    Set DestinationSheet = Sheet1: Rem adjust  <<<<<<<<<
   
    HowMany = Application.InputBox("How many buttons", Default:=5, Type:=1)
    If HowMany < 2 Then Exit Sub
   
    ReDim BaseArray(1 To HowMany)
    For i = 1 To HowMany
        BaseArray(i) = Chr(64 + i)
    Next i
   
    chooseHowMany = Application.InputBox("choose how many from " & HowMany, Default:=3, Type:=1)
    If chooseHowMany < 1 Or HowMany < chooseHowMany Then Exit Sub
  
    Choice.FromN(chooseHowMany) = HowMany
    DestinationSheet.Cells.ClearContents
   
    Do
        ChosenArray = Choice.ActingOn(BaseArray)
        Set Permutation = New clsPermuation
       
        Do
            thisArray = Permutation.ActingOn(ChosenArray)
            DestinationSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, chooseHowMany).Value = thisArray
   
            Set Permutation = Permutation.NextPermutation
        Loop Until Permutation.Level > Choice.ChooseK
        Set Choice = Choice.NextChoice(choiceFlag)
    Loop Until choiceFlag
End Sub

 

[kstatinet]

mikerickson, thank you very much!! (i only had to change spelling for clsPermutation and it worked). Considering it is first time me running VBA script, I consider it a success.
It works for (1)

I know I'm probably asking too much at this point, but if you have a chance/time to see how (2) from my original question can be solved w/VBA, I would appreciate this!

Thank you again.

 

[mikerickson]

Run Test .
In the second dialog box, enter 4 instead of the default 3.

 

[kstatinet]

Maybe I didn't clarify enough about (2) from my OP.

(2) is a different type of permutation. It is not 4 single buttons pressed once out 5 button options in which case indeed you would enter in a second dialog box and get 120 unique permutations.

Instead, in this question, you would press any TWO buttons together and then TWO other buttons separately. None of the buttons can be repeated. In this case, you would get 180 unique permutations.
3 * ( 5 1 ) * ( 4 1 ) * ( 3 2 ) = 180

So, it's a different coding from (1)

 

[mikerickson]

So you want A A B C and to permute that?

 

[kstatinet]

| = separate buttons ;
+ = buttons pressed together

No. Let say we have buttons A B C D E. In case (2) you can press 2 buttons together and 2 buttons separately. None of the unique combinations (total will be 180) might have any button repeated.

Example:

1) A + B | C | D
2) A | B + C | D
3) A | B | C +D
..
180) E+A | C | D

 

[mikerickson]

is A | B+C | D the same as A | C+B | D

but different from D | B+C | A

 

[kstatinet]

yes

 

[kstatinet]

mikerickson.. it's too late going to bed. thank you for all your help! i need to learn to code. it is ok' if this question (2) won't be answered for now. have a great rest of the week!