How to create list of all possible combinations (10C4) not permutations

[anna_25]

Hi!

I need to list down all possible 4 combinations out of 10 items (e.g. A, B, C, D, E, F, G, H, I, J). I'm looking for combinations, not permutations so order is not taken into consideration. Computing, I should end up with 210 combinations.

I've seen fantastic threads similar to this but they're all for permutations. I have a limited knowledge of Excel, so it would be much appreciated if the solution suggested is simple and easy to follow.

Hope someone can help

Thanks so much!
Anna

 

[Armando Montes]

Look here:
Myrna Larson code for Combinations and Permutations not working in Excel 07-Overflow

 

[anvg]

It is a combination variant

'test with one-dimensional array of 10 items
Public Sub test()
    Dim t(1 To 10) As String, i As Long, v
    For i = 1 To 10
        t(i) = CStr(i)
    Next i
    v = Combination(t, 4)
    ActiveSheet.Range("A1").Resize(UBound(v), UBound(v, 2)).Value = v
End Sub
Public Function Combination(ByRef this As Variant, ByVal subSet As Long) As Variant
    Dim vIndex() As Long, i As Long, iRow As Long
    Dim vFirst As Long, vLast As Long, vCount As Long
    Dim vResult() As Long, vOffset As Long, k As Long, p As Long
    
    vFirst = LBound(this): vLast = UBound(this)
    vCount = vLast - vFirst + 1: vOffset = vFirst - 1
    ReDim vIndex(1 To subSet)
    For i = 1 To subSet
        vIndex(i) = i
    Next
    ReDim vResult(1 To CLng(CombinationCount(vCount, subSet)), 1 To subSet)
    iRow = 1
    p = subSet
    Do While p >= 1
        For i = 1 To subSet
            vResult(iRow, i) = this(vIndex(i) - vOffset)
        Next
        iRow = iRow + 1
        If vIndex(subSet) = vCount Then
            p = p - 1
        Else
            p = subSet
        End If
        If p >= 1 Then
            For i = subSet To p Step -1
                vIndex(i) = vIndex(p) + i - p + 1
            Next
        End If
    Loop
    Combination = vResult
End Function
Public Function Factorial(ByVal Start As Long) As Double
    If Start > 1 Then
        Factorial = Start * Factorial(Start - 1#)
    Else
        Factorial = 1
    End If
End Function
Public Function CombinationCount(ByVal Base As Long, ByVal subSet As Long) As Double
    CombinationCount = Factorial(Base) / Factorial(subSet) / Factorial(Base - subSet)
End Function

 

[anna_25]

Look here:
Myrna Larson code for Combinations and Permutations not working in Excel 07-Overflow

Thanks! I tried this but got the message:

"Compile error:

Sub or Function not defined"

And it refers to: UBound(Buffer()

 

[anvg]

Please change in function Combination
Dim vResult() As Long, vOffset As Long, k As Long, p As Long
To
Dim vResult() As Variant, vOffset As Long, k As Long, p As Long

 

[mikerickson]

Perhaps this would work for you.

Sub test()
    Dim FromCount As Long, ChooseCount As Long, i As Long
    Dim blnFlags() As Boolean, oFlow As Boolean
    Dim outArray() As String, writeTo As Range
    Set writeTo = Range("Q1")
    
    FromCount = 10
    ChooseCount = 4
    
    ReDim blnFlags(1 To FromCount)
    
    For i = 1 To ChooseCount
        blnFlags(i) = True
    Next i
    
    ReDim outArray(1 To WorksheetFunction.Combin(FromCount, ChooseCount))
    i = 0
    Do Until oFlow
        i = i + 1
        outArray(i) = StringFromArray(blnFlags)
        blnFlags = NextArray(blnFlags, oFlow)
    Loop
    
    With writeTo
        .EntireColumn.ClearContents
        .Resize(UBound(outArray), 1).Value = Application.Transpose(outArray)
    End With
    
    MsgBox UBound(outArray) & " combinations"
End Sub

Function StringFromArray(CharacterArray As Variant)
    Dim i As Long, Low As Long, High As Long
    Low = LBound(CharacterArray): High = UBound(CharacterArray)
    For i = Low To High
        If CharacterArray(i) Then
            StringFromArray = StringFromArray & Chr(64 + (i - Low + 1))
        End If
    Next i
End Function

Function NextArray(currentArray As Variant, Optional ByRef OverFlow As Boolean) As Variant
    Dim outputArray As Variant
    Dim Low As Long, High As Long
    Dim Pointer As Long, outPoint As Long
    
    Low = LBound(currentArray): High = UBound(currentArray)
    outputArray = currentArray
    
    Pointer = Low: outPoint = Low
    
    Do Until currentArray(Pointer)
        Pointer = Pointer + 1
    Loop
    
    On Error GoTo OvrFlow
    Do Until Not (currentArray(Pointer))
        outputArray(Pointer) = False
        outputArray(outPoint) = True
        outPoint = outPoint + 1
        Pointer = Pointer + 1
    Loop

    outputArray(outPoint - 1) = False
    outputArray(Pointer) = True
    outputArray(Pointer - 1) = False
    
OvrFlow:
    OverFlow = CBool(Err)
    Err.Clear
    NextArray = outputArray
End Function