Excel VBA中的组合算法
Posted
技术标签:
【中文标题】Excel VBA中的组合算法【英文标题】：Combination Algorithm in Excel VBA 【发布时间】：2011-11-04 02:49:53 【问题描述】：我需要一种算法，它可以生成一组数字的所有可能组合，并将它们全部输出到 Excel 电子表格中。
例如，使用 n = 5(1,2,3,4,5) 和 r = 2（为此创建了一个小 gui），它将生成所有可能的组合并将它们输出到这样的 excel 电子表格中。 .
1,2
1,3
1,4
...
打印的顺序无关紧要。它可以先打印 (5,1)，然后打印 (1,2)。 谁能告诉我如何做到这一点？
非常感谢。
【问题讨论】：
订单重要吗？ 5,1 和 1,5 一样吗？ 如果顺序（正如 Tim 所问的）很重要，那么“所有可能的组合”可以快速增长。如果 n 和 r 均为 8，则为阶乘 8，或超过 40,000 个排列。你对 n 有限制吗？ 是的，顺序很重要。很抱歉没有把它放进去。1,5 和 5,1 一样。 不，我对 n 或 r 没有限制。我想让它动态化，这样任何用户都可以输入任何数字，它会生成包含所有可能组合的电子表格。 不敢相信还没有人问过这个问题：你自己尝试过什么吗？答案基本上是两个嵌套的For Next 循环。
【参考方案1】：
这段代码怎么样...
Option Explicit
Private c As Integer
Sub test_print_nCr()
print_nCr 5, 3, Range("A1")
End Sub
Function print_nCr(n As Integer, r As Integer, p As Range)
c = 1
internal_print_nCr n, r, p, 1, 1
End Function
Private Function internal_print_nCr(n As Integer, r As Integer, ByVal p As Range, Optional i As Integer, Optional l As Integer) As Integer
' n is the number of items we are choosing from
' r is the number of items to choose
' p is the upper corner of the output range
' i is the minimum item we are allowed to pick
' l is how many levels we are in to the choosing
' c is the complete set we are working on
If n < 1 Or r > n Or r < 0 Then Err.Raise 1
If i < 1 Then i = 1
If l < 1 Then l = 1
If c < 1 Then c = 1
If r = 0 then
p = 1
Exit Function
End If
Dim x As Integer
Dim y As Integer
For x = i To n - r + 1
If r = 1 Then
If c > 1 Then
For y = 0 To l - 2
If p.Offset(c - 1, y) = "" Then p.Offset(c - 1, y) = p.Offset(c - 2, y)
Next
End If
p.Offset(c - 1, l - 1) = x
c = c + 1
Else
p.Offset(c - 1, l - 1) = x
internal_print_nCr n, r - 1, p, x + 1, l + 1
End If
Next
End Function
【讨论】：
谢谢！现在我只需要弄清楚如何在每个单元格上打印它们。我是 VBA 新手，所以过去 2 天我一直在学习它。【参考方案2】：我不得不这样做一次，最终适应了this algorithm。它与嵌套循环有些不同，因此您可能会觉得它很有趣。翻译成VB，会是这样的：
Public Sub printCombinations(ByRef pool() As Integer, ByVal r As Integer)
Dim n As Integer
n = UBound(pool) - LBound(pool) + 1
' Please do add error handling for when r>n
Dim idx() As Integer
ReDim idx(1 To r)
For i = 1 To r
idx(i) = i
Next i
Do
'Write current combination
For j = 1 To r
Debug.Print pool(idx(j));
'or whatever you want to do with the numbers
Next j
Debug.Print
' Locate last non-max index
i = r
While (idx(i) = n - r + i)
i = i - 1
If i = 0 Then
'All indexes have reached their max, so we're done
Exit Sub
End If
Wend
'Increase it and populate the following indexes accordingly
idx(i) = idx(i) + 1
For j = i + 1 To r
idx(j) = idx(i) + j - i
Next j
Loop
End Sub
【讨论】：
谢谢。我试过了，它工作正常，但 Excel 电子表格中的数组输入不是我想要的。但我试过了，它非常适合任何可能需要它的人。 这就是我说“类似”的原因:-) @Joubarc 它是否适用于这样的事情：array(2,3,4,5,7,10),where r=3？【参考方案3】：这些组合算法最好使用带有递归的嵌套循环。大约 4 年前，我编写了执行此操作所需的代码 (https://vitoshacademy.com/vba-nested-loops-with-recursion)。这个想法是改变Main中的size变量和同一个Sub中的输入数组。然后运行它：
Sub Main()
Static size As Long
Static c As Variant
Static arr As Variant
Static n As Long
size = 2
c = Array(1, 2, 3, 4, 5, 6)
n = UBound(c) + 1
ReDim arr(size - 1)
EmbeddedLoops 0, size, c, n, arr
End Sub
Function EmbeddedLoops(index, k, c, n, arr)
Dim i As Variant
If index >= k Then
PrintArrayOnSingleLine arr
Else
For Each i In c
arr(index) = i
EmbeddedLoops index + 1, k, c, n, arr
Next i
End If
End Function
debug.print 在 VBA 中具有内置限制，在即时窗口中仅显示最后 200 个值 (Ctrl+G)。因此，如果您有超过 200 行的结果，最好写入 Excel 电子表格、txt.file 或数据库：
Public Sub PrintArrayOnSingleLine(myArray As Variant)
Dim counter As Integer
Dim textArray As String
For counter = LBound(myArray) To UBound(myArray)
textArray = textArray & myArray(counter)
Next counter
Debug.Print textArray
End Sub
【讨论】：
【参考方案4】：这是我使用数组 vba 的解决方案
Private Sub UserForm_Initialize()
Dim matriz_origen() As Variant
Dim matriz_destino() As Variant
Dim n As Long
Dim k As Long
n = 6
k = 2
Call combinatoria(matriz_origen, matriz_destino, n, k)
'Def titulo
Title = "Matriz Combinatoria"
'FUnction Calling
Call despliegue_2D(matriz_destino, Style, Title)
End Sub
Function combinatoria(matriz() As Variant, comb As Long, _
matriz_origen() As Variant, matriz_destino() As Variant, _
n As Long, k As Long)
'This function is calculating all possible combinations.
comb = Application.WorksheetFunction.Combin(n, k) 'Sin repeticion
ReDim matriz_origen(1 To n, 1 To k)
'Loops
For j = 1 To k
For i = 1 To n
matriz_origen(i, j) = i
Next i
Next j
ReDim matriz_destino(1 To comb, 1 To k) 'comb
If (k = 2) Then
cont1 = 1
'Loops
For j = 1 To k - 1
pos1 = j + 1
For i = 1 To n
For iter1 = 1 To n
If matriz_origen(i, j) < matriz_origen(iter1, pos1) Then
matriz_destino(cont1, j) = matriz_origen(i, j)
matriz_destino(cont1, pos1) = matriz_origen(iter1, j)
cont1 = cont1 + 1
End If
Next iter1
Next i
Next j
End If
If (k = 3) Then
cont1 = 1
'Loops
For j = 1 To k - 2
pos1 = j + 1
pos2 = j + 2
For i = 1 To n
For iter1 = 1 To n
If matriz_origen(i, j) < matriz_origen(iter1, pos1) Then
For iter2 = 1 To n
If matriz_origen(iter1, pos1) < matriz_origen(iter2, pos2) Then
matriz_destino(cont1, j) = matriz_origen(i, j)
matriz_destino(cont1, pos1) = matriz_origen(iter1, j)
matriz_destino(cont1, pos2) = matriz_origen(iter2, j)
cont1 = cont1 + 1
End If
Next iter2
End If
Next iter1
Next i
Next j
End If
If (k = 4) Then
cont1 = 1
'Loops
For j = 1 To k - 3
pos1 = j + 1
pos2 = j + 2
pos3 = j + 3
For i = 1 To n
For iter1 = 1 To n
If matriz_origen(i, j) < matriz_origen(iter1, pos1) Then
For iter2 = 1 To n
If matriz_origen(iter1, pos1) < matriz_origen(iter2, pos2) Then
For iter3 = 1 To n
If matriz_origen(iter2, j) < matriz_origen(iter3, pos1) Then
matriz_destino(cont1, j) = matriz_origen(i, j)
matriz_destino(cont1, pos1) = matriz_origen(iter1, j)
matriz_destino(cont1, pos2) = matriz_origen(iter2, j)
matriz_destino(cont1, pos3) = matriz_origen(iter3, j)
cont1 = cont1 + 1
End If
Next iter3
End If
Next iter2
End If
Next iter1
Next i
Next j
End If
End Function
Function despliegue_2D(matriz() As Variant, Style As String, Title As String)
'Esta funcion permite el despliegue de un arreglo multidimentinal de 2 dimensiones.
'Declaration
Dim msg As String
Dim iter1 As Integer, iter2 As Integer
'Declaration
filas = UBound(matriz, 1)
columnas = UBound(matriz, 2)
'Loops
For iter1 = 1 To filas
For iter2 = 1 To columnas
msg = msg & matriz(iter1, iter2) & vbTab
Next iter2
msg = msg & vbCrLf
Next iter1
Response = MsgBox(msg, Style, Title)
End Function
【讨论】：
最后加入数组 欢迎来到 SO！当您发布回复时，请尝试检查它是否是原始问题的答案。在您的情况下，如果是，我们无法打结，因为您的代码的一部分正在调用未公开为 despliegue_1D 的过程。您正在修复项目的数量，这是可变的...编辑您的回复并完成您的代码。 感谢您的 cmets，我将使用附加函数和矩阵来完成我的代码。以上是关于Excel VBA中的组合算法的主要内容，如果未能解决你的问题，请参考以下文章