CODEWITHSUNDEEP
excelvba
user118282
user118282

Reputation: 25

Find all possible combinations of a list in vba

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....

Upvotes: 1

Views: 6683

Answers (2)

RichieV
RichieV

Reputation: 5183

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

Upvotes: 0

Gary&#39;s Student
Gary&#39;s Student

Reputation: 96791

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

Upvotes: 1

Related Questions