问题
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
回答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.
来源：https://stackoverflow.com/questions/51711328/iterating-through-combinations-of-groups-of-4-within-a-group-of-16