Find all possible combinations of a list in vba - excel

Question

I am trying to organise a list of data "a,b,c,d,e,...." into all possible combinations of 1,2,3....n elements.
For example:
a,b,c,d,e
a
b
c
d
e
a,b
a,c
a,d
a,e
b,c
b,d
d,e
...
and so on.
So far I have only come across people who have written code to find the combinations to two sets of data rather than one.
Would you know where to start?
In my head it would be similar to the following so it would run systematically, and stops any repeats of the permutations. So essentially I would be running a loop inside another loop 4 or 5 different times.
i
i+1
i+...n
i,j+1
.
.
.
i,j,k,l....

Answer 1

I asked a similar question about 10 years ago and got a great answer from John Coleman:
Gray Code
Here is his solution:
'If you run TestThis, then for example the second message box returns
'
'{}
'dog
'dog , cat
'cat
'cat , mouse
'dog , cat, mouse
'dog , mouse
'mouse
'mouse , zebra
'dog , mouse, zebra
'dog , cat, mouse, zebra
'cat , mouse, zebra
'cat , zebra
'dog , cat, zebra
'dog , zebra
'zebra
'
'Hope this helps,
'
'John Coleman
'p.s. The algorithm used to generate the Gray code comes from the
'excellent book "Combinatorial Algorithms: Generation, Enumeration and
'Search " by Kreher and Stinson."
and the code:
Sub TestThis()
Dim i As Integer
Dim A(3 To 7) As Integer
Dim B As Variant
For i = 3 To 7
A(i) = i
Next i
B = Array("dog", "cat", "mouse", "zebra")
MsgBox ListSubsets(A)
MsgBox ListSubsets(B)
End Sub
Function ListSubsets(Items As Variant) As String
Dim CodeVector() As Integer
Dim i As Integer
Dim lower As Integer, upper As Integer
Dim SubList As String
Dim NewSub As String
Dim done As Boolean
Dim OddStep As Boolean
OddStep = True
lower = LBound(Items)
upper = UBound(Items)
ReDim CodeVector(lower To upper) 'it starts all 0
Do Until done
'Add a new subset according to current contents
'of CodeVector
NewSub = ""
For i = lower To upper
If CodeVector(i) = 1 Then
If NewSub = "" Then
NewSub = Items(i)
Else
NewSub = NewSub & ", " & Items(i)
End If
End If
Next i
If NewSub = "" Then NewSub = "{}" 'empty set
SubList = SubList & vbCrLf & NewSub
'now update code vector
If OddStep Then
'just flip first bit
CodeVector(lower) = 1 - CodeVector(lower)
Else
'first locate first 1
i = lower
Do While CodeVector(i) <> 1
i = i + 1
Loop
'done if i = upper:
If i = upper Then
done = True
Else
'if not done then flip the *next* bit:
i = i + 1
CodeVector(i) = 1 - CodeVector(i)
End If
End If
OddStep = Not OddStep 'toggles between even and odd steps
Loop
ListSubsets = SubList
End Function

Answer 2

I know this question is old, but I wrote the code before finding John Coleman's option.
In order to find different rank combinations (i.e. sets of 2,3,4 items) I put the list of items in ColumnA of a clean sheet, with a header, and call it with something like:
Sub call_listcombos()
Dim sht as Worksheet, outrn As Range
Dim n As Integer, r As Integer, rto As Integer
Dim poslist()
Application.ScreenUpdating = False
Set sht = ActiveSheet
n = sht.Range("A1").CurrentRegion.Rows.Count - 1
poslist() = Application.Transpose(sht.Range("A2").Resize(n).Value2)
rto = 2
Do While Application.Combin(n, rto + 1) < 250000
DoEvents
rto = rto + 1
Loop
For r = 2 To rto
Set outrn = sht.Range("A1").Offset(sht.Range("A1").CurrentRegion.Rows.Count)
Call list_combos(poslist(), r, outrn)
Next r
Application.ScreenUpdating = True
End Sub
The code:
Private Sub list_combos(items() As Variant, r As Integer, outrange As Range)
'receives a 1-D variant array and outputs a single column with nCr combinations
'selecting r items without replacement... n > r > 1 :: integers
Dim n As Integer, i As Integer, ri As Integer, outi As Long
Dim comboindex(), comboitems()
n = UBound(items) - LBound(items) + 1
outi = Application.Combin(n, r)
'test output range
If outrange.Row + outi > 1000000 Then
MsgBox "Too many combinations! Will not fit in output range."
Exit Sub
End If
If Application.CountA(outrange.Resize(outi)) > 0 Then
MsgBox "Output range is not empty!"
Exit Sub
End If
'initialize combinations
ReDim comboindex(1 To r)
ReDim comboitems(1 To r)
For ri = 1 To r
comboindex(ri) = LBound(items) + ri - 1 'sets comboindex's base to items' base
comboitems(ri) = items(comboindex(ri))
Next ri
'loop combinations
ri = r
outi = 0
Do While comboindex(ri) <= UBound(items)
DoEvents
For i = comboindex(ri) To UBound(items)
comboindex(ri) = i
comboitems(ri) = items(comboindex(ri))
outrange.Offset(outi).Value2 = Join(comboitems, ";")
outi = outi + 1
Next i
ri = ri - 1
Do While comboindex(ri) + 1 = comboindex(ri + 1)
DoEvents
If ri = 1 Then Exit Do
ri = ri - 1
Loop
comboindex(ri) = comboindex(ri) + 1
comboitems(ri) = items(comboindex(ri))
Do While ri < r
DoEvents
ri = ri + 1
comboindex(ri) = comboindex(ri - 1) + 1
If comboindex(ri) > UBound(items) Then Exit Do
comboitems(ri) = items(comboindex(ri))
Loop
Loop
End Sub