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]

I think this will do what you want.
With the workbook with the class modules from above, add a new normal module and add this to it.
To vary things up, strAlphabet and strPattern Could be changed.

' in normal module

Dim Choosing() As clsChoice, partitionCount As Long: Rem zero based
Dim arrAlphabet As Variant, alphaCount As Long: Rem one based
Const strPipe As String = "|"
Const Delimiter As String = "+"

Sub MixedStuff()
    Dim strPattern As String
    Dim i As Long, strAlphabet As String
    Dim subPatterns As Variant, baseParts As Variant
    Dim xVal As Variant
    Dim oneChoice As clsChoice
    Dim strTest As String, lookMoreFlag As Boolean, oneSub As Variant
    Dim ovFlag As Boolean
    Dim Destinationsheet As Worksheet
    Dim onePerm As clsPermuation, strOut As String, arrOut As Variant
    
    Set Destinationsheet = Sheet1
    strAlphabet = "ABCDE"
    strPattern = "x+x|x|x"
    
    alphaCount = Len(strAlphabet)
    ReDim arrAlphabet(1 To alphaCount)
    For i = 1 To alphaCount
        arrAlphabet(i) = Mid(strAlphabet, i, 1)
    Next i
     
    subPatterns = Split(strPattern, strPipe)
    partitionCount = UBound(subPatterns) + 1
    
    ReDim Choosing(0 To partitionCount - 1)
    For i = 0 To partitionCount - 1
        Set oneChoice = New clsChoice
        xVal = Split(subPatterns(i), Delimiter)
        oneChoice.FromN(UBound(xVal) + 1) = alphaCount
        Set Choosing(i) = oneChoice
    Next i
    Set oneChoice = Nothing
        
    Destinationsheet.Cells.ClearContents
    
    Do
      
        Do
            Call NextPartition(ovFlag)
            If ovFlag Then Exit Do
            strTest = CurrentPartition(baseParts)
            strTest = strPipe & Replace(strTest, Delimiter, strPipe) & strPipe
            lookMoreFlag = False
            For Each oneSub In Split(strTest, strPipe)
                If Len(strTest) - Len(Replace(strTest, oneSub, vbNullString)) > Len(oneSub) Then
                    lookMoreFlag = True
                End If
            Next oneSub
        Loop While lookMoreFlag
        
        If Not ovFlag Then
            If IsError(Application.Match(CurrentPartition, Destinationsheet.Range("A:A"), 0)) Then
                ' output this partition
                Set onePerm = New clsPermuation
                Do
                    arrOut = onePerm.ActingOn(baseParts)
                    strOut = vbNullString
                    For i = LBound(arrOut) To UBound(arrOut)
                        strOut = strOut & strPipe & arrOut(i)
                    Next i
                    strOut = Mid(strOut, Len(strPipe) + 1)
                    Destinationsheet.Range("A65536").End(xlUp).Offset(1, 0).Value = strOut
                    Set onePerm = onePerm.NextPermutation
                Loop Until partitionCount < onePerm.Level
            End If
        End If
    Loop Until ovFlag
    Set onePerm = Nothing
    Set oneChoice = Nothing
End Sub

Sub NextPartition(Optional ByRef blnReturn As Boolean)
    Dim lookAt As Long
    Dim oVal As Boolean
    lookAt = partitionCount - 1
    Do
        Set Choosing(lookAt) = Choosing(lookAt).NextChoice(oVal)
        lookAt = lookAt - 1: If lookAt < 0 Then Exit Do
    Loop While oVal
    blnReturn = oVal And (lookAt < 0)
End Sub

Function CurrentPartition(Optional ByRef Subs As Variant) As String
    Dim i As Long, j As Long
    Dim subPartitions() As String
    ReDim subPartitions(0 To partitionCount - 1)
    For i = 0 To partitionCount - 1
        For j = 1 To alphaCount
            If Choosing(i).ChoiceArray(j) Then
                subPartitions(i) = subPartitions(i) & Delimiter & arrAlphabet(j)
            End If
        Next j
        subPartitions(i) = Mid(subPartitions(i), Len(Delimiter) + 1)
    Next i
    Subs = subPartitions
    CurrentPartition = Join(subPartitions, strPipe)
End Function