Macro to create all possible unique combinations of groups of numbers

[trpltongue]

Hello all,

I've been reading and working like crazy trying to make a silly thing work in excel vba and am at a roadblock.

I have a set of 30 numbers 1-30 that I want to place into 3 groups of 5, for example:

Group 1 - 1,2,3,4,5
Group 2 - 6,7,8,9,10
Group 3 - 11,12,13,14,15

However, each number can be used only once, so I cannot have for example:
Group 1 - 1,2,3,4,5
Group 2 - 5,4,3,2,1
Group 3 - 6,7,8,9,10

I'd like to use vba to generate all of the unique families of 3 groups of 5 numbers automatically.

So something like:

Family 1:
Group 1 - 1,2,3,4,5
Group 2 - 6,7,8,9,10
Group 3 - 11,12,13,14,15

Family 2:
Group 1 - 1,2,3,4,5
Group 2 - 6,7,8,9,10
Group 3 - 11,12,13,14,16

Family 3:
Group 1 - 1,2,3,4,5
Group 2 - 6,7,8,9,10
Group 3 - 11,12,13,14,17

Etc.

I've read all through Myrna Larson's code and have no problem generating all of the possible 5 number combinations, it's just putting them into unique 3-group combinations that is troublesome.

Thanks so much for any help.

 

[trpltongue]

Paddydive,

I restarted excel and the code ran fine, not sure the problem. However, it doesn't quite do what I need it to do. I need all the combinations, not just 1.

PGC,

I searched and found this code that you actually wrote back in 2009:

http://www.mrexcel.com/forum/excel-...e-list-all-pair-combinations.html#post2046159

This code generates permutations.

- write the set of elements in a continuous range, starting in A1, down (in your case write the codes in A1:A7)
- write how many numbers are picked up for each permutation in B1 (in your case B1=2)
- the result is writen starting in C1


This is almost perfect, except that it generates duplicate permutations.

For example, this code gives the following permutations for 6 numbers out of 10
10, 9, 8, 7, 6, 5
8, 9, 10, 7, 6, 5

As you can see, these 2 permutations are non-unique if ignorning their order.

In my setup, I would break these into 2 groups:
Permutation1: Group1: 10, 9, 8 Group2: 7, 6, 5
Permutation2: Group1: 8, 9, 10 Group2:7, 6, 5

As you can see, Group 1 is the same in both cases, just arranged in a different order.

This is very close to what I'm after, and I could perhaps write some other post-processing code to remove duplicates. I'll keep searching to see if I can find more details on unique permutations.

Thanks!

 

[pgc01]

Hi

I think we have a problem with terminology, that is making it difficult to understand what you need.

In combinatorics you have:

- combinations, when you arrange a set of elements in groups of a certain size, and the order in which the elements of this group is presented is not relevant. So if you want combinations of 10 elements taken 6 at a time, 123456 and 654321 is the same combination.

- permutations, when you arrange a set of elements in groups of a certain size, and the order in which the elements of this group is presented is relevant. So if you want permutations of 10 elements taken 6 at a time, 123456 and 654321 are different permutations.


I asked in post #6 if a result of 2 groups of 4 elements "1234 5678" and "2314 5687" are equivalent. You anwered in post #8 that these 2 results are not equivalent. The only difference in the 2 results is the order of the elements inside each group.

Now you say in your last post (#11) that "10, 9, 8 - 7, 6, 5" and "8, 9, 10 - 7, 6, 5" should be considered the same (just arranged in a different order). I am confused.

I have already understood that there cannot be duplicate elements neither in a group nor across groups.

What I have not yet understood is about the relevance of the order of the elements in a group or of the groups themselves.

What I'd like is to have clear rules that would allow me to look at cases like the 3 I write below and to know if they are equivalent.

1 - "123 456" and "134 256" both results use "123456"
2 - "123 456" and "132 465" in both results the groups have the same elements, although displayed in a different order
3 - "123 456" and "456 123" the same 2 groups in both results, although in a different order

Please clarify.

 

[trpltongue]

PGC,

My sincere apologies. I was running out the door when I replied with post 8 and simply misread the question.

To clarify:
Case 1: Not Equivalent
Case 2: Equivalent
Case 3: Equivalent

Again, sorry for the earlier mixup. I should have known better than to reply as I was leaving.

 

[pgc01]

Ok. It seems is like what I said first. You get the combinations of 10 elements taken 6 at a time and then use the first 3 elements for the first group and the last 3 elements for the second group.

Try this code to get the combinations:

Sub Combinations()
Dim rRng As Range, p
Dim vElements, lRow As Long, vResult As Variant, vResults As Variant
 
vElements = VBA.Array("a", "b", "c", "d", "e", "f", "g", "h", "i", "j")
p = 6
ReDim vResult(0 To p - 1)
ReDim vResults(1 To Application.WorksheetFunction.Combin(UBound(vElements) + 1, p), 1 To 1)

Call CombinationsNP(vElements, CInt(p), vResult, vResults, lRow, 0, 0)

' the combinations are in vResults. For ex. write it to the worksheet
[COLOR=#ff0000]Range("A2").Resize(UBound(vResults)) = vResults
[/COLOR]End Sub
 
Sub CombinationsNP(vElements As Variant, p As Integer, vResult As Variant, vResults, lRow As Long, iElement As Integer, iIndex As Integer)
Dim i As Integer
 
For i = iElement To UBound(vElements)
    vResult(iIndex) = vElements(i)
    If iIndex = p - 1 Then
        lRow = lRow + 1
        vResults(lRow, 1) = Join(vResult, ",")
    Else
        Call CombinationsNP(vElements, p, vResult, vResults, lRow, i + 1, iIndex + 1)
    End If
Next i
End Sub

You get all the combinations in an array. In this case is an array(1 to 210, 1 to 1) where you have all the 210 combinations.
Each combination has the elements separated by commas, like "a,b,c,d,e,f", "a,b,c,d,e,g", etc..

Just to see the result I wrote the array in cells of column A.
You just have to replace the statement in red to display the results as you see fit.

Please try

 

[trpltongue]

PGC,

Many thanks again for your efforts in solving this. I still don't think the above code captures all the possibilities.

As an example, if I ran the code using only 6 elements taken 6 at a time I get only 1 result a,b,c,d,e,f.

However, in my case I would want to get:
a,b,c d,e,f
a,b,d c,e,f
a,b,e d,c,f
etc.

This is similar to your "123 456" and "134 256" example above.

These are all unique combinations that are excluded when using the above code and simply splitting the results into 2 groups.

 

[pgc01]

You are right. This was my turn to misread your answer.

If I understand correctly it's what I wrote in post #6. This is a multinomial distribution. I never wrote code for this, so what I did was to adapt the code from the combinations to take into account that each result is not a combination, but a group of combinations.

Please test and post back.

' PGC 2013
' Generate multinomial groups of n distinct elements taken in groups of p1, p2, ...pn elements with no duplicates in or across groups
' Ex. out of a set of 10 elements, generate pairs of groups of 3 elements each,

Sub Multinomial()
Dim vElements As Variant, vResult As Variant, vResults As Variant
Dim lRow As Long, p As Variant

vElements = VBA.Array("a", "b", "c", "d", "e", "f", "g", "h", "i", "j")
p = VBA.Array(3, 3)

ReDim vResult(0 To Application.Sum(p) - 1)
ReDim vResults(1 To Application.Fact(UBound(vElements) + 1) / Application.Product(Application.Fact(p)) / Application.Fact(UBound(vElements) + 1 - Application.Sum(p)), 1 To 1)

Call MultinomialNP(vElements, p, vResult, vResults, lRow, 0, 0, 0, 0)

' the multinomial groups  are in vResults. For ex. write it to the worksheet
Range("A2").Resize(UBound(vResults)) = vResults
End Sub
 
Sub MultinomialNP(ByVal vElements As Variant, ByRef p As Variant, ByVal vResult As Variant, ByRef vResults As Variant, _
                  ByRef lRow As Long, ByVal lElement As Long, ByVal lIndex As Long, ByVal lP As Long, ByVal lOffset As Long)
Dim l As Long, k As Long, vElements2 As Variant
 

For l = lElement To UBound(vElements)
    vResult(lIndex + lOffset) = vElements(l)
    If lIndex = p(lP) - 1 Then
        If lP = UBound(p) Then
            lRow = lRow + 1
            vResults(lRow, 1) = Join(vResult, ",")
        Else
            vElements2 = vElements
            For k = 0 To UBound(vElements)
                vElements2(k) = IIf(IsNumeric(Application.Match(vElements(k), vResult, 0)), Chr(1), vElements(k))
            Next k
            Call MultinomialNP(Filter(vElements2, Chr(1), False), p, vResult, vResults, lRow, _
                                      0, 0, lP + 1, lIndex + lOffset + 1)
        End If
    Else
        Call MultinomialNP(vElements, p, vResult, vResults, lRow, l + 1, lIndex + 1, lP, lOffset)
    End If
Next l
End Sub

 

[trpltongue]

PGC,

Again, I can't thank you enough for your efforts on this. This is almost perfect. The only issue is that there are still some repeats later in the series.

Once the first element of the first group goes above 1, some duplicates begin showing up for example:

Early in the code we have "156 234" as a set of 2 groups
Later in the code we have "234 156" as a set of 2 groups

Unfortunately, those are equivalent pairings of groups.

I can use the code and then filter out whenever the first value of a group is smaller than the first value of the previous group (if using numbers), but doing it in memory would be much faster, and likely the only way I could adapt it to larger numbers of elements.

Again, thank you SO much for your help in this. My code is cludgy at best and I am taking a brute force approach which takes ages to run for even 10 elements.

 

[pgc01]

Sorry, you are right, we still have to eliminate the duplicate groups.
The most difficult part is, however, done. I had never done the multinomial which made this interesting.

I don't think I'll be able to do it during the day but I'll do it at night(GMT).
I also wanted to change the output format. I'm thinking a jagged array that reflects the multinomial structure.

 

[trpltongue]

That is fantastic! I do really appreciate your help with this.

Any output format is fine. I personally will be outputting it into sequential rows x columns wide.

1 2 3 4 5 6
1 2 4 3 5 6
1 2 5 3 4 6

etc.

Again, I really appreciate the help.

 

[pgc01]

Hi

In this solution I prefer not to change the code that generates the multinomial distribution. What I do instead is to write some post-processing code (call in red) that takes the result of the multinomial distribution and filters the results where the groups are the same but in different order.

The code is not optimised but seems to be working.

It has 2 outputs: on the columns to the left the multinomial groups, in your example 4200, and on the columns to the right your result. After you test you can suppress the first output and just print yours.

Please try:

' PGC 2013 Jan
' Generate multinomial groups of n distinct elements taken in groups of p1, p2, ...pn elements with no duplicates in or across groups
' Ex. out of a set of 10 elements, generate pairs of groups of 3 elements each,
Sub Multinomial()
Dim vElements As Variant, vResult As Variant, vResults As Variant, vResults1 As Variant
Dim lRow As Long, p As Variant, n As Long
Dim i As Long, j As Long, k As Long, l As Long
Dim v As Variant

n = 10
p = VBA.Array(3, 3)

ReDim vElements(0 To n - 1)
For j = 0 To n - 1
    vElements(j) = Format(j, "00")
Next j
ReDim vResult(0 To Application.Sum(p) - 1)
ReDim vResults(0 To Application.Fact(UBound(vElements) + 1) / Application.Product(Application.Fact(p)) / 

Application.Fact(UBound(vElements) + 1 - Application.Sum(p)) - 1, 1 To 1)

Call MultinomialNP(vElements, p, vResult, vResults, lRow, 0, 0, 0, 0)

' divide the array separating the groups
ReDim vResults1(0 To UBound(p))
For j = 0 To UBound(p)
    ReDim v(0 To UBound(vResults), 0 To p(j) - 1)
    vResults1(j) = v
Next j
For j = 0 To UBound(p)
    For k = 0 To UBound(vResults)
        v = Split(Mid(vResults(k, 1), l + 1, p(j) * 3 - 1), ",")
        For i = 0 To UBound(v)
            vResults1(j)(k, i) = v(i)
        Next i
    Next k
    l = l + 3 * p(j)
Next j

' write to the worksheet for control
l = 0
For j = 0 To UBound(p)
    Range("A2").Resize(UBound(vResults1(0)) + 1, p(j)).Offset(, l) = vResults1(j)
    l = l + p(j) + 1
Next j

' post-processing for no results where the same groups appear in different order
[COLOR=#ff0000]ndp vResults1, p
[/COLOR]End Sub
 

Sub MultinomialNP(ByVal vElements As Variant, ByRef p As Variant, ByVal vResult As Variant, ByRef vResults As Variant, _
                  ByRef lRow As Long, ByVal lElement As Long, ByVal lIndex As Long, ByVal lP As Long, ByVal lOffset As Long)
Dim l As Long, k As Long, vElements2 As Variant
 
For l = lElement To UBound(vElements)
    vResult(lIndex + lOffset) = vElements(l)
    If lIndex = p(lP) - 1 Then
        If lP = UBound(p) Then
            vResults(lRow, 1) = Join(vResult, ",")
            lRow = lRow + 1
        Else
            vElements2 = vElements
            For k = 0 To UBound(vElements)
                vElements2(k) = IIf(IsNumeric(Application.Match(vElements(k), vResult, 0)), Chr(1), vElements(k))
            Next k
            Call MultinomialNP(Filter(vElements2, Chr(1), False), p, vResult, vResults, lRow, _
                                      0, 0, lP + 1, lIndex + lOffset + 1)
        End If
    Else
        Call MultinomialNP(vElements, p, vResult, vResults, lRow, l + 1, lIndex + 1, lP, lOffset)
    End If
Next l
End Sub


Sub ndp(vResults As Variant, p As Variant)
Dim j As Long, k As Long, l As Long, lR As Long, lRow As Long, b As Boolean
Dim vResults1 As Variant, v As Variant

For lRow = 0 To UBound(vResults(0))
    b = True
    For j = 0 To UBound(p) - 1
        For l = j + 1 To UBound(p)
            If p(l) = p(j) Then
                If vResults(j)(lRow, 0) > vResults(l)(lRow, 0) Then
                    b = False
                    Exit For
                End If
            End If
        Next l
        If b = False Then Exit For
    Next j
    If b Then
        If lR <> lRow Then
            For j = 0 To UBound(p)
                For l = 0 To p(j) - 1
                    vResults(j)(lR, l) = vResults(j)(lRow, l)
                Next l
            Next j
        End If
    End If
    If b Then lR = lR + 1
Next lRow

ReDim vResults1(0 To UBound(p))
For j = 0 To UBound(p)
    ReDim v(0 To lR - 1, 0 To p(j) - 1)
    vResults1(j) = v
Next j

For j = 0 To UBound(p)
    For lRow = 0 To lR - 1
        For k = 0 To p(j) - 1
            vResults1(j)(lRow, k) = vResults(j)(lRow, k)
        Next k
    Next lRow
Next j


' write to the worksheet for control
l = 0
For j = 0 To UBound(p)
    Cells(2, Application.Sum(p) + UBound(p) + 3).Resize(UBound(vResults1(0)) + 1, p(j)).Offset(, l) = vResults1(j)
    l = l + p(j) + 1
Next j

End Sub