VBA recursive “For loops” Permutation?

Question

Below is my code. I would like to achieve the same result by recursive method because the number of nested loops is varying from 2 to max 8.

Sub permutation()

         


        

Answer 1

For future readers, OP's needs essentially follows a Cartesian Product, a mathematical operation of all ordered pairs between sets. One can easily run the Cross Join SQL query or specifically a query without any JOIN statements to achieve the resultset. This is also known as the full outer join query.

Some SQL engines like SQL Server use the CROSS JOIN statement with a resultset equal to rows of product of each included query table (e.g., 2*2*2*2*2*2*2*2 = 2^8 = 256).

In MS Access (the database sibling to MS Excel), using tables defined as the 8 arrays of two items, below would be the cross join query. Item field in each Array table carries the pairing (1,2), (3,4), (5,6) ...

SELECT Array1.Item, Array2.Item, Array3.Item, Array4.Item, 
       Array5.Item, Array6.Item, Array7.Item, Array8.Item
FROM Array1, Array2, Array3, Array4, 
     Array5, Array6, Array7, Array8;

Design

Output

Excel solution

Because VBA can connect to various SQL engines by associated drivers including Excel's ODBC Jet Driver, a workbook can connect to ranges of worksheets and run the same cross join query:

Sub CrossJoinQuery()

    Dim conn As Object
    Dim rst As Object
    Dim sConn As String, strSQL As String

    Set conn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")

    sConn = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
               & "DBQ=C:\Path To\Excel\Workbook.xlsx;"
    conn.Open sConn

    strSQL = "SELECT * FROM [ArraySheet1$A1:A3], [ArraySheet2$A1:A3], 
                            [ArraySheet3$A1:A3], [ArraySheet4$A1:A3],
                            [ArraySheet5$A1:A3], [ArraySheet6$A1:A3], 
                            [ArraySheet7$A1:A3], [ArraySheet8$A1:A3]"
    rst.Open strSQL, conn

    Range("A1").CopyFromRecordset rst

    rst.Close
    conn.Close

    Set rst = Nothing
    Set conn = Nothing

End Sub

Answer 2

I approached it as a binary problem:

Public Sub Perms(lCyles As Long)

    Dim sBin As String
    Dim i As Long
    Dim j As Long
    Dim n As Long

    With Sheets("Criteria")
        .Cells.Clear
        n = 1
        For i = 0 To 2 ^ lCyles - 1
            sBin = WorksheetFunction.Dec2Bin(i)
            sBin = String(lCyles - Len(sBin), "0") & sBin
            For j = 1 To Len(sBin)
                .Cells(n, j) = IIf(Mid(sBin, j, 1) = "1", j * 2, j * 2 - 1)
            Next j
            n = n + 1
        Next i
    End With

End Sub

Answer 3

If you still want the fix to the code to produce the desired outcome.

Sub RecurseMe(a, v, depth, rw)

    If a > depth Then
        rw = rw + 1
        PrintV v, rw
        Exit Sub
    End If
    For x = 1 To 2
        v(a) = x + ((a - 1) * 2)
        a = a + 1
        RecurseMe a, v, depth, rw
        a = a - 1
    Next x
End Sub

Sub PrintV(v, rw)
    For j = 1 To UBound(v)
        ActiveSheet.Cells(rw, j) = v(j) ' & " ";
    Next j
End Sub
Sub test()
    Dim v()
    Dim rw As Long
    rw = 0
    depth = 8 'adjust to adjust the number of columns
    a = 1
    ReDim v(1 To depth)
    RecurseMe a, v, depth, rw
End Sub