Generate table of combinations

[Gary's Student]

Can anyone point me to an algorithm or VBA code to produce a table of
combination of items. For example if the items are 1,2,3,4,5 then the code
would generate:

1
1, 2
1, 2, 3
1, 2, 3, 4
1, 2, 3, 5
1, 2, 3, 4, 5
1, 2, 4
1, 2, 4, 5
1, 2, 5
1, 3
1, 3, 4
1, 3, 4, 5
1, 3, 5
1, 4
1, 4, 5
1, 5
2
2, 3
2, 3, 4
2, 3, 4, 5
2, 3, 5
2, 4
2, 4, 5
2, 5
3
3, 4
3, 4, 5
3, 5
4
4, 5
5

Similar for dog, cat, house
--
Gary's Student

[Tom Ogilvy]

http://tinyurl.com/7jqeo

Code previously posted by Myrna Larson. Not a complete solution, but you
could run it multiple times with different number of values in the subsets.

--
Regards,
Tom Ogilvy

"Gary's Student" <GarysS...@discussions.microsoft.com> wrote in message
news:1FD10426-1802-47E1...@microsoft.com...

[KL]

Hi,

Have a look at this:
http://www.excelforum.com/archive/index.php/t-258299.html

Regards,
KL

"Gary's Student" <GarysS...@discussions.microsoft.com> wrote in message
news:1FD10426-1802-47E1...@microsoft.com...

[Gary's Student]

Thank you both very much.
--
Gary's Student

[John Coleman]

You could use a Gray code - which is what your example seems to be
trying to do:

Option Explicit

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

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

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.

[Gary's Student]

Thank you John.

I'll look for your reccomended book
--
Gary's Student