Комбинированный алгоритм в Excel VBA

Как насчет этого кода...

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

Мне пришлось сделать это один раз, и в итоге я адаптировал это алгоритм. Это несколько отличается от вложенных циклов, поэтому может показаться вам интересным. В переводе на 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

Эти комбинированные алгоритмы лучше всего использовать с вложенными циклами с рекурсией. Около 4 лет назад я написал точно необходимый код для этого (http://vitoshacademy.com/vba-nested-loops-with-recursion). Идея состоит в том, чтобы изменить переменную size в Main и входной массив в том же 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 значений в окне Immediate (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

Это мое решение с массивами 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