Excel 在16个组中迭代4个组的组合
大家好，我知道这个问题看起来与其他一些问题相似，但我已经对它们进行了广泛的研究，无法让它们为我工作 我有16个数据集，让我们称它们为1到16。我想通过各种可能的不同方式将这16个人分成4组；最基本的例子是：[1,2,3,4][5,6,7,8][9,10,11,12][13,14,15,16] 问题是如何最好地迭代这些组合（在vba中） 下面我提供了一个更详细的例子来帮助说明我试图实现的目标，我迄今为止的思维过程，我尝试过的代码，以及为什么它不起作用Excel 在16个组中迭代4个组的组合,excel,vba,iteration,combinations,permutation,Excel,Vba,Iteration,Combinations,Permutation,大家好，我知道这个问题看起来与其他一些问题相似，但我已经对它们进行了广泛的研究，无法让它们为我工作 我有16个数据集，让我们称它们为1到16。我想通过各种可能的不同方式将这16个人分成4组；最基本的例子是：[1,2,3,4][5,6,7,8][9,10,11,12][13,14,15,16] 问题是如何最好地迭代这些组合（在vba中） 下面我提供了一个更详细的例子来帮助说明我试图实现的目标，我迄今为止的思维过程，我尝试过的代码，以及为什么它不起作用 示例另一个有效的组合可以是[2,4,6,8]
示例另一个有效的组合可以是[2,4,6,8][10,12,14,16][1,3,5,7][9,11,13,15]等。但是，我希望避免任何重复：第一类重复包括组内重复的元素，或相同组合的另一组：[1,2,2,4]。。。或[1,2,3,4][4,5,6,7]。。。第2类复制涉及与上一次迭代相同的组，例如[1,2,4,3][5,6,8,7][9,10,12,11][13,14,16,15] 思考过程我希望避免任何重复，特别是因为这将大大减少我需要比较的组合数量。我试图通过使用一个函数来避免类型1，该函数比较组合中的所有元素，看看是否有相同的元素。我试图通过确保每个组中的元素始终以升序排列，以及确保每个组中的第一个元素也始终以升序排列来避免类型2。（这应该有用，不是吗？） 代码 下面是我尝试过的两个代码示例。第一个简单地崩溃了excel（如果你这么想的话，我有一个值而不是一个大数字）；我想有太多的组合要一个接一个地进行？ 第二个并没有给我唯一的组，它返回相同的组，每个组中只有第一个值被更改 一, 二, 组和临时组是二维数组，第一个值是组号，第二个值是该组中的元素号。
InArray是我制作的一个函数（相当不言自明）
在本例中，我使用比较标准将最近的“最佳”组集与当前的“临时组”迭代进行比较，并保存最佳的组集，以便与下一次迭代进行比较 没有帮助的链接：
虽然这很有用，但它只查看集合中一个组的组合，我想查看集合中多个组的组合 这更多地着眼于排列（重新排列组的顺序，而不是组合）
我看到的几乎所有其他解决方案都属于这些类别之一从概念上讲，这个问题并没有那么难。我们需要做的就是生成所有
16排列，并删除4对所有4个组重复。最后，我们需要删除4整个组的重复次数。因此，我们应该取得近300万项成果：
16! / (4!^5) = 2,627,625
作为一个例子，如果我们考虑1到16中的前10个排列，则我们有：
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)
如您所见，所有这些都是相同的，因为最后一个组是唯一被置换的对象（OP不希望）。如果我们继续生成并查看排列20到30，我们有：
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)
我们注意到，如果我们用前455个组合中不存在的组合填充其他3组，我们最终会复制组合456到459。例如，组合291到294是：
291 (1 6 7 8)
292 (1 6 7 9)
293 (1 6 7 10)
294 (1 6 7 11)
如果我们要填写这些组合中每个组合的补码的所有可能组合，请选择4（例如，对于291的补码选择（2 3 4 5 9 10 11 12 13 15 16）
），前面显示的那些组合（456到459）将已经被考虑
这是一个很好的结果。这意味着我们可以在第一个“组”完成后停止生成结果（例如，当第一个组中的第一个数字保持为1时）。同样的想法也适用于我们进一步的群体
下面我们有一些辅助函数，用于计算组合、生成组合和获取向量的补码。组合生成器非常高效，可以在我的旧Windows机器上在3秒钟多的时间内生成所有520300个25-12的组合
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
选项显式
函数nCr（n为长，r为长）为长
暗分辨率为长，i为长，温度为双
温度=1
对于i=1到r:temp=temp*（n-r+i）/i:Next i
nCr=圆形（温度）
端函数
Sub-GetCombosNoRep（ByRef combos（）长，n长，r长，numRows长）
将索引（）变长
模糊的数字一样长，我一样长，k一样长，计数一样长
ReDim索引（1到r）
计数=1
对于i=1到r:index（i）=i:Next
当计数0.00001或r<2或r>=n时，则
MsgBox“输入错误！！！”
“”您可以有自定义消息，如：MsgBox“#个数据集不能被#个组分割！！！”
出口接头
如果结束
定时器
gSize=n/r
总计=1
Dim AllCombs（）作为变型，tN作为长型
重拨所有梳（1至r-1）
tN=n
对于i=1到r-1
myRows=nCr（tN，gSize）
ReDim组合（1到myRows，1到gSize）
调用GetCombosNoRep（combos、tN、gSize、myRows）
总计=总计*myRows/（r-（i-1））
AllCombs（i）=组合
tN=tN-gSize
接下来我
将主组（）变暗为相同的长度
ReDim主组（1到总计，1到r，1到gSize）
暗秒长度等于长，s等于长，e等于长，m等于长
secLength=nCr（n，gSize）/r
Dim v（）长，child（）长，q长，temp长
雷迪姆v（1至n）
对于i=1到n:v（i）=i：下一个i
重拨子项（1到gSize）
暗淡的超色如长，numReps A
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)
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)
291 (1 6 7 8)
292 (1 6 7 9)
293 (1 6 7 10)
294 (1 6 7 11)
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
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