Seeking method to list all combinations of six numbers, with a twist

[auto.pilot]

I've seen other threads on this topic but can't find anything to fit my needs. I am seeking a method to list all combinations of numbers 1, 2, 3, 4, 5 & 6. However, I also need all of the combinations of fewer numbers. Examples:

1,3,5 and 2,3,6 and 1,3,4,5,6

However, I don't need repeats, meaning that 1,3,5 for me is the same as 5,1,3.

How can I do this?

Thanks in advance.

Jim

 

[mikerickson]

Try this
Put 1,2,3,4,5,6 in A1:F1

if you want three letter combos, put 1,2,3 in A2:C2

Then put the array formula =NextValues(A2:C2, $A$1:$F$1) in A3:C3 and drag down as needed.

Dim Alphabet() As String
Dim Choice() As Boolean
Dim Output() As String

Function NextValues(currentValues As Range, myAlphabet As Range)
    Dim someLetters As Variant, Pointer As Long, oneCell As Range
    someLetters = Application.Transpose(myAlphabet.Value)
    SetAlphabet someLetters
    Pointer = 0
    ReDim Output(1 To currentValues.Cells.Count)
    For Each oneCell In currentValues
        Pointer = Pointer + 1
        If UBound(Output) < Pointer Then ReDim Preserve Output(1 To 2 * Pointer)
        Output(Pointer) = CStr(oneCell.Value)
    Next oneCell
    ReDim Preserve Output(1 To Pointer)
    ChoiceFromOutput
    NextChoice
    OutputFromChoice
    NextValues = Output
End Function

Sub OutputFromChoice()
    Dim i As Long, Pointer As Long
    ReDim Output(1 To 1)
    For i = 1 To UBound(Choice)
        If Choice(i) Then
            Pointer = Pointer + 1
            If UBound(Output) < Pointer Then ReDim Preserve Output(1 To 2 * Pointer)
            Output(Pointer) = Alphabet(i)
        End If
    Next i
    ReDim Preserve Output(1 To Pointer)
End Sub
Sub ChoiceFromOutput()
    Dim i As Long
    For i = 1 To UBound(Choice)
        Choice(i) = IsNumeric(Application.Match(Alphabet(i), Output, 0))
    Next i
End Sub

Sub NextChoice(Optional ByRef Overflow As Boolean)
    Dim lookAt As Long, writeTo As Long
    
    lookAt = 1
    writeTo = 1
    Do Until Choice(lookAt)
        lookAt = lookAt + 1
    Loop
    
    Do Until Not Choice(lookAt)
        Choice(lookAt) = False
        Choice(writeTo) = True
        writeTo = writeTo + 1
        lookAt = lookAt + 1
        Overflow = (lookAt > UBound(Choice))
        If Overflow Then Exit Sub
    Loop
    Choice(writeTo - 1) = False
    Choice(lookAt) = True
End Sub


Sub SetAlphabet(Optional Letters As Variant, Optional Size As Long = 4)
    'Dim Size As String
    Dim oneLetter As Variant
    Dim i As Long
    If Not IsMissing(Letters) Then
        If TypeName(Letters) Like "*()" Then
            Size = UBound(Letters) - LBound(Letters) + 1
        Else
            
        End If
    End If
    ReDim Alphabet(1 To Size)
    ReDim Choice(1 To Size)
    
    For i = 1 To Size
            Alphabet(i) = i
    Next i
    If Not IsMissing(Letters) Then
        If TypeName(Letters) Like "*()" Then
        i = 1
        For Each oneLetter In Letters
            Alphabet(i) = oneLetter
            i = i + 1
            If Size < i Then Exit For
        Next oneLetter
        End If
    End If
End Sub