I need an algorithm which generates 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
For Nextloops.