Combination Algorithm in Excel VBA

I need an algorithm which gene开发者_如何学Pythonrates all possible combination of a set number and output all of them onto Excel spreadsheet.

For example, with n = 5(1,2,3,4,5) and r = 2(created a small gui for this), it will generate all possible combinations and output them into excel spreadsheet like this...

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

The order in which it prints doesn't matter. It can first print (5,1), then (1,2). Can anyone show me how to do this?

Thank you very much.

---

How about this code...

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

---

I had to do this once and ended up adapting this algorithm. It's somewhat different from nested loops, so you may find it interesting. Translated to VB, this would be something like this:

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

---

These combination algorithms are best made with nested loops with recursion. I have wrote some 4 years ago the exactly needed code to carry this out (https://vitoshacademy.com/vba-nested-loops-with-recursion). The idea is to change the size variable in the Main and the input array in the same Sub. Then run it:

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

The debug.print has built-in limit in VBA, displaying only the last 200 values in the Immediate Window (Ctrl+G). Thus, if you have more than 200 lines of results, it is better to write to Excel spreadsheet, to a txt.file or to a database:

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

---

This is my solution with arrays 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