Iterating through combinations of groups of 4 within a group of 16

Question

Hi all, I know this question looks similar to some others but I have trawled through them extensively and can't get them to work for me.

I have 16 datasets, let's call them 1 to 16. I would like to iterate through every possible different way of collecting these 16 into 4 groups; the most basic example being : [1,2,3,4][5,6,7,8][9,10,11,12][13,14,15,16].

The Question is how can I best iterate throught these combinations (in vba)?

Below I have provided a more detailed example to help illustrate what I am trying to achieve, my thought proccesses to date, the code I have tried, and why it hasn't worked.

---

Example Another valid combination could be [2,4,6,8][10,12,14,16][1,3,5,7][9,11,13,15], etc etc. However, I would like to avoid any duplication: a type one duplication would include elements repeated within a group, or another group of the same combination: [1,2,2,4]... OR [1,2,3,4][4,5,6,7]... A type 2 duplication would involve the same groups as a previous iteration, for example [1,2,4,3][5,6,8,7][9,10,12,11][13,14,16,15].

Thought Process I would like to avoid any duplication, especially as this will massively cut down the number of combinations I will have to compare. I have tried to avoid type 1 by using a function that compares all the elements in a combination to see if any are the same. I have tried to avoid type 2 by ensuring the elements in each group are always in ascending order, and ensuring the first element from each group is always in ascending order too. (This should work shouldn't it?)

Code Below are two examples of code I have tried. The first one simply crashed excel (I did have a value instead of large number if that's what you're thinking); I'd imagine there are just too many combinations to go through one by one? The second doesn't give me unique groups, it returns the same groups with only the first value in each one changed.

1.

Sub CombGen()

Dim Combs(1 To 1820)
Dim Comb(1 To 4)


Dim GroupsCombs(1 To *large number*)
Dim GroupsComb(1 To 1820)



x = 1
For a = 1 To 16 - 3
Comb(1) = a
 For b = a + 1 To 16 - 2
 Comb(2) = b
  For c = b + 1 To 16 - 1
  Comb(3) = c
   For d = c + 1 To 16
    Comb(4) = d
    Combs(x) = Comb
    x = x + 1
   Next d
  Next c
 Next b
Next a


x = 1
For a = 1 To 1820 - 3
GroupsComb(1) = a
 For b = a + 1 To 1820 - 2
 GroupsComb(2) = b
  For c = b + 1 To 1820 - 1
  GroupsComb(3) = c
   For d = c + 1 To 1820
    GroupsComb(4) = d
    If Repeat(a, b, c, d, Combs) = False Then
     GroupsCombs(x) = Comb
     x = x + 1
    End If
   Next d
  Next c
 Next b
Next a


End Sub

Function Repeat(a, b, c, d, Combs)
 Repeat = False
 Dim letters(1 To 4): letters(1) = a: letters(2) = b: letters(3) = c: letters(4) = d
 Dim i: Dim j
 Repeat = False
 For x = 1 To 4
  For y = 2 To 4
   For i = 1 To 4
    For j = 1 To 4
     If Combs(letters(i))(x) = Combs(letters(j))(y) Then
      Repeat = True
     End If
    Next j
   Next i
  Next y
 Next x
End Function

2.

For a = 1 To 16 - 3
 For b = a + 1 To 16 - 2
  For c = b + 1 To 16 - 1
   For d = c + 1 To 16
    TempGroups(1, 1) = a: TempGroups(1, 2) = b: TempGroups(1, 3) = c: TempGroups(1, 4) = d

    For e = 1 To 16 - 3
    If InArray(TempGroups, e) = False Then
     For f = e + 1 To 16 - 2
     If InArray(TempGroups, f) = False Then
      For g = f + 1 To 16 - 1
      If InArray(TempGroups, g) = False Then
       For h = g + 1 To 16          
        If InArray(TempGroups, h) = False Then
        TempGroups(2, 1) = e: TempGroups(2, 2) = f: TempGroups(2, 3) = g: TempGroups(2, 4) = h

        For i = 1 To 16 - 3
        If InArray(TempGroups, i) = False Then
         For j = i + 1 To 16 - 2
         If InArray(TempGroups, j) = False Then
          For k = j + 1 To 16 - 1
          If InArray(TempGroups, k) = False Then
           For l = k + 1 To 16               
            If InArray(TempGroups, l) = False Then
            TempGroups(3, 1) = i: TempGroups(3, 2) = j: TempGroups(3, 3) = k: TempGroups(3, 4) = l

            For m = 1 To 16 - 3
            If InArray(TempGroups, m) = False Then
             For n = m + 1 To 16 - 2
             If InArray(TempGroups, n) = False Then
              For o = n + 1 To 16 - 1
              If InArray(TempGroups, o) = False Then
               For p = o + 1 To 16
               If InArray(TempGroups, p) = False Then
                TempGroups(3, 1) = m: TempGroups(3, 2) = n: TempGroups(3, 3) = o: TempGroups(3, 4) = p

                If *comparison criteria are met* Then
                 For x = 1 To 4
                  For y = 1 To 4
                   Groups(x, y) = TempGroups(x, y)
                  Next y
                 Next x
                End If

               End If
               Next p
              End If
              Next o
             End If
             Next n
            End If
            Next m

           End If
           Next l
          End If
          Next k
         End If
         Next j
        End If
        Next i

       End If
       Next h
      End If
      Next g
     End If
     Next f
    End If
    Next e

   Next d
  Next c
 Next b
Next a

End If

Groups and TempGroups are 2D arrays, the first value being the group number and the second being the element number in that group.
InArray is a function I made (fairly self explanatory)
In this instance, I am using a comparison criteria to compare the most recent "best" set of groups with the current iteration of "tempgroups" and saving the best one, ready to be compared to the next iteration

Links that didn't help:
How can I iterate throught every possible combination of n playing cards While this was useful, it only looked at the combinations of one group within the set, I would like to look at the combinations of multiple groups within the set

Listing all permutations of a given set of values This looked more at permutations (rearranging the order of groups as opposed to the combinations)

Pretty much all the other solutions I looked at fell into one of these categories

Answer 1

Conceptually, this problem isn't that hard. All we need to do is generate all 16! permutations, and remove 4! of within-group repeats for all 4 groups. Finally, we need to remove 4! of repeats for the groups as a whole. So we should obtain nearly 3 million results:

16! / (4!^5) = 2,627,625

As an example, if we consider the first 10 permutations of 1 through 16 in lexicographical order, we have:

 1 (1 2 3 4) (5 6 7 8) (9 10 11 12) (13 14 15 16)
 2 (1 2 3 4) (5 6 7 8) (9 10 11 12) (13 14 16 15)
 3 (1 2 3 4) (5 6 7 8) (9 10 11 12) (13 15 14 16)
 4 (1 2 3 4) (5 6 7 8) (9 10 11 12) (13 15 16 14)
 5 (1 2 3 4) (5 6 7 8) (9 10 11 12) (13 16 14 15)
 6 (1 2 3 4) (5 6 7 8) (9 10 11 12) (13 16 15 14)
 7 (1 2 3 4) (5 6 7 8) (9 10 11 12) (14 13 15 16)
 8 (1 2 3 4) (5 6 7 8) (9 10 11 12) (14 13 16 15)
 9 (1 2 3 4) (5 6 7 8) (9 10 11 12) (14 15 13 16)
10 (1 2 3 4) (5 6 7 8) (9 10 11 12) (14 15 16 13)

As you can see, all of these are identical as the last group is the only thing that is being permuted (which the OP doesn't want). If we continue generating and look at permutations 20 through 30 we have:

20 (1 2 3 4) (5 6 7 8) (9 10 11 12) (16 13 15 14)
21 (1 2 3 4) (5 6 7 8) (9 10 11 12) (16 14 13 15)
22 (1 2 3 4) (5 6 7 8) (9 10 11 12) (16 14 15 13)
23 (1 2 3 4) (5 6 7 8) (9 10 11 12) (16 15 13 14)
24 (1 2 3 4) (5 6 7 8) (9 10 11 12) (16 15 14 13)
25 (1 2 3 4) (5 6 7 8) (9 10 11 13) (12 14 15 16) <- a different combination
26 (1 2 3 4) (5 6 7 8) (9 10 11 13) (12 14 16 15)
27 (1 2 3 4) (5 6 7 8) (9 10 11 13) (12 15 14 16)
28 (1 2 3 4) (5 6 7 8) (9 10 11 13) (12 15 16 14)
29 (1 2 3 4) (5 6 7 8) (9 10 11 13) (12 16 14 15)
30 (1 2 3 4) (5 6 7 8) (9 10 11 13) (12 16 15 14)

Finally at permutation #25, we get a new custom combination that the OP is after.

If we keep going, eventually permutation #5606234726401 (yes, that is over 5 trillion) is an example of where the groups are exactly the same as the first few permutations, only these groups are permuted (again, these are the arrangements we want to avoid):

5606234726401 (5 6 7 8) (1 2 3 4) (9 10 11 12) (13 14 15 16) <- same as the 1st permutation
5606234726402 (5 6 7 8) (1 2 3 4) (9 10 11 12) (13 14 16 15)
5606234726403 (5 6 7 8) (1 2 3 4) (9 10 11 12) (13 15 14 16)
5606234726404 (5 6 7 8) (1 2 3 4) (9 10 11 12) (13 15 16 14)
5606234726405 (5 6 7 8) (1 2 3 4) (9 10 11 12) (13 16 14 15)
5606234726406 (5 6 7 8) (1 2 3 4) (9 10 11 12) (13 16 15 14)
5606234726407 (5 6 7 8) (1 2 3 4) (9 10 11 12) (14 13 15 16)
5606234726408 (5 6 7 8) (1 2 3 4) (9 10 11 12) (14 13 16 15)
5606234726409 (5 6 7 8) (1 2 3 4) (9 10 11 12) (14 15 13 16)
5606234726410 (5 6 7 8) (1 2 3 4) (9 10 11 12) (14 15 16 13)

The point is, we need a method that will avoid these within-group as well as group permutations because the sheer computational power required (no matter how efficient are algorithm is) to generate and sift through that many permutations is simply not feasible.

We need a different approach. Let's look at a set of the combinations of 16 choose 4, say 450 through 460:

450 (1 12 14 16)
451 (1 12 15 16)
452 (1 13 14 15)
453 (1 13 14 16)
454 (1 13 15 16)
455 (1 14 15 16)
456 (2 3 4 5)  
457 (2 3 4 6)  
458 (2 3 4 7)  
459 (2 3 4 8)  
460 (2 3 4 9)

We note here, that if we were to fill in the other 3 groups with the combinations not present in the first 455 combinations, we would eventually replicate combinations 456 through 459. For example, the combinations 291 through 294 are:

291 (1 6 7 8) 
292 (1 6 7 9) 
293 (1 6 7 10)
294 (1 6 7 11)

And if we were to fill in all of the possible combinations of the complement of each of these combinations choose 4 (e.g. (2 3 4 5 9 10 11 12 13 14 15 16) for the complement of 291), those combinations shown earlier (456 through 459) will already be accounted for.

This is a nice result. This means we can simply stop generating results after the first "group" has completed (e.g. while the 1st number in the 1st group stays 1). The same thinking applies as we move to further groups.

Below we have some helper functions for counting combinations, generating combinations, and getting the complement of a vector. The combination generator is very efficient and can generate all 5,200,300 combinations of 25 choose 12 in just over 3 seconds on my old Windows machine.

Option Explicit

Function nCr(n As Long, r As Long) As Long
Dim res As Long, i As Long, temp As Double
    temp = 1
    For i = 1 To r: temp = temp * (n - r + i) / i: Next i
    nCr = Round(temp)
End Function

Sub GetCombosNoRep(ByRef combos() As Long, n As Long, r As Long, numRows As Long)

Dim index() As Long
Dim numIter As Long, i As Long, k As Long, count As Long

    ReDim index(1 To r)
    count = 1
    For i = 1 To r: index(i) = i: Next

    While count <= numRows
        numIter = n - index(r) + 1

        For i = 1 To numIter
            For k = 1 To r
                combos(count, k) = index(k)
            Next k
            count = count + 1
            index(r) = index(r) + 1
        Next i

        For i = r - 1 To 1 Step -1
            If index(i) <> (n - r + i) Then
                index(i) = index(i) + 1
                For k = i + 1 To r
                    index(k) = index(k - 1) + 1
                Next k

                Exit For
            End If
        Next i
    Wend

End Sub

Sub GetComplement(n As Long, childVec() As Long, complementVec() As Long)

Dim i As Long, j As Long

    ReDim logicalVec(1 To n)
    For i = 1 To n: logicalVec(i) = True: Next i
    For i = 1 To UBound(childVec): logicalVec(childVec(i)) = False: Next i
    j = 1

    For i = 1 To n
        If logicalVec(i) Then
            complementVec(j) = i
            j = j + 1
        End If
    Next i

End Sub

And here is the main sub routine:

Sub MasterGenerator()

Dim myRows As Long, i As Long, j As Long, r As Long, n As Long
Dim combos() As Long, k As Long, gSize As Long, total As Long
Dim sTime As Double, eTime As Double, verbose As Boolean

    n = CLng(InputBox("How many datasets do you have?", "ENTER # OF DATASETS", "16"))
    r = CLng(InputBox("How many groups do you have?", "ENTER # OF GROUPS", "4"))
    verbose = CBool(InputBox("Should the results be printed?", "VERBOSE OPTION", "True"))

    If Abs(Round(n / r) - (n / r)) > 0.00001 Or r < 2 Or r >= n Then
        MsgBox "Incorrect input!!!"
        '' You could have custom message like: MsgBox "# of Datasets is NOT divisible by # of Groups!!!"
        Exit Sub
    End If

    sTime = Timer
    gSize = n / r
    total = 1

    Dim AllCombs() As Variant, tN As Long
    ReDim AllCombs(1 To r - 1)
    tN = n

    For i = 1 To r - 1
        myRows = nCr(tN, gSize)
        ReDim combos(1 To myRows, 1 To gSize)
        Call GetCombosNoRep(combos, tN, gSize, myRows)
        total = total * myRows / (r - (i - 1))
        AllCombs(i) = combos
        tN = tN - gSize
    Next i

    Dim MasterGroups() As Long
    ReDim MasterGroups(1 To total, 1 To r, 1 To gSize)

    Dim secLength As Long, s As Long, e As Long, m As Long
    secLength = nCr(n, gSize) / r

    Dim v() As Long, child() As Long, q As Long, temp As Long
    ReDim v(1 To n)
    For i = 1 To n: v(i) = i: Next i

    ReDim child(1 To gSize)
    Dim superSecLen As Long, numReps As Long
    superSecLen = total
    Dim endChild() As Long, endV() As Long
    ReDim endChild(1 To n - gSize)
    ReDim endV(1 To gSize)

    '' Populate all but the last 2 columns
    If r > 2 Then
        For i = 1 To r - 2
            numReps = nCr(n - (i - 1) * gSize, gSize) / (r - (i - 1))
            secLength = superSecLen / numReps
            s = 1: e = secLength

            If i = 1 Then
                For j = 1 To numReps
                    For k = s To e
                        For m = 1 To gSize
                            MasterGroups(k, i, m) = v(AllCombs(i)(j, m))
                        Next m
                    Next k
                    s = e + 1
                    e = e + secLength
                Next j
            Else
                ReDim child(1 To (i - 1) * gSize)
                ReDim v(1 To n - (i - 1) * gSize)

                While e < total
                    '' populate child vector so we can get the complement
                    For j = 1 To i - 1
                        For m = 1 To gSize
                            child(m + (j - 1) * gSize) = MasterGroups(s, j, m)
                        Next m
                    Next j

                    Call GetComplement(n, child, v)

                    For q = 1 To numReps
                        For k = s To e
                            For m = 1 To gSize
                                MasterGroups(k, i, m) = v(AllCombs(i)(q, m))
                            Next m
                        Next k
                        s = e + 1
                        e = e + secLength
                    Next q
                Wend
            End If

            superSecLen = secLength
        Next i

        numReps = nCr(n - (r - 2) * gSize, gSize) / (r - 2)
        s = 1: e = secLength

        ReDim child(1 To (r - 2) * gSize)
        ReDim v(1 To n - (r - 2) * gSize)

        While e <= total
            '' populate child vector so we can get the complement
            For j = 1 To r - 2
                For m = 1 To gSize
                    child(m + (j - 1) * gSize) = MasterGroups(s, j, m)
                    endChild(m + (j - 1) * gSize) = MasterGroups(s, j, m)
                Next m
            Next j

            Call GetComplement(n, child, v)
            q = 1

            For k = s To e
                For m = 1 To gSize
                    MasterGroups(k, r - 1, m) = v(AllCombs(r - 1)(q, m))
                    endChild(m + (r - 2) * gSize) = MasterGroups(k, r - 1, m)
                Next m

                q = q + 1
                Call GetComplement(n, endChild, endV)

                For m = 1 To gSize
                    MasterGroups(k, r, m) = endV(m)
                Next m
            Next k
            s = e + 1
            e = e + secLength
        Wend
    Else
        For k = 1 To total
            For m = 1 To gSize
                MasterGroups(k, 1, m) = v(AllCombs(1)(k, m))
                endChild(m) = MasterGroups(k, 1, m)
            Next m

            Call GetComplement(n, endChild, endV)

            For m = 1 To gSize
                MasterGroups(k, 2, m) = endV(m)
            Next m
        Next k
    End If

    If verbose Then
        Dim myString As String, totalString As String, printTotal As Long
        printTotal = Application.WorksheetFunction.Min(100000, total)

        For i = 1 To printTotal
            totalString = vbNullString
            For j = 1 To r
                myString = vbNullString
                For k = 1 To gSize
                    myString = myString & " " & MasterGroups(i, j, k)
                Next k
                myString = Right(myString, Len(myString) - 1)
                myString = "(" & myString & ") "
                totalString = totalString + myString
            Next j
            Cells(i, 1) = totalString
        Next i
        eTime = Timer - sTime
        MsgBox "Generation of " & total & " as well as printing " & printTotal & " custom combinations  completed in : " & eTime & " seconds"
    Else
        eTime = Timer - sTime
        MsgBox "Generation of " & total & " custom combinations completed in : " & eTime & " seconds"
    End If

End Sub

I know it is a bit much, but it is very general and decently fast. If you run Sub MasterGenerator and enter 8 for the # of datasets, and 2 for the number of groups like this:

You get the following results:

For the OP's specific case, there are over 2 million results so we can't print them all in one column. However, running with Verbose = False, the custom combinations are generated in about 12 seconds.