Excel VBA中的组合算法

Question

我需要一种算法，它可以生成一组数字的所有可能组合，并将它们全部输出到 Excel 电子表格中。

例如，使用 n = 5(1,2,3,4,5) 和 r = 2（为此创建了一个小 gui），它将生成所有可能的组合并将它们输出到这样的 excel 电子表格中。 .

1,2
1,3
1,4
...

打印的顺序无关紧要。它可以先打印 (5,1)，然后打印 (1,2)。 谁能告诉我如何做到这一点？

非常感谢。

Answer 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

Answer 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

Answer 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

Answer 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