VBA递归“For循环”排列？答案

【问题标题】：VBA recursive "For loops" Permutation?VBA递归“For循环”排列？
【发布时间】：2015-12-28 16:55:16
【问题描述】：

下面是我的代码。我想通过递归方法达到相同的结果，因为嵌套循环的数量从 2 到最大 8 不等。

Sub permutation()

c1 = Array(1, 2)
c2 = Array(3, 4)
c3 = Array(5, 6)
c4 = Array(7, 8)
c5 = Array(9, 10)
c6 = Array(11, 12)
c7 = Array(13, 14)
c8 = Array(15, 16)

With Sheets("Criteria")
    .Cells.Clear
    n = 1
    For a = LBound(c1) To UBound(c1)
        For b = LBound(c2) To UBound(c2)
            For c = LBound(c3) To UBound(c3)
                For d = LBound(c4) To UBound(c4)
                    For e = LBound(c5) To UBound(c5)
                         For f = LBound(c6) To UBound(c6)
                             For g = LBound(c7) To UBound(c7)
                                 For h = LBound(c8) To UBound(c8)

                                Cells(n, 1).Value = c1(a)
                                Cells(n, 2).Value = c2(b)
                                Cells(n, 3).Value = c3(c)
                                Cells(n, 4).Value = c4(d)
                                Cells(n, 5).Value = c5(e)
                                Cells(n, 6).Value = c6(f)
                                Cells(n, 7).Value = c7(g)
                                Cells(n, 8).Value = c8(h)
                                n = n + 1

                                Next h
                            Next g
                        Next f
                    Next e
                Next d
            Next c
        Next b
    Next a
End With
End Sub

我还在互联网上找到了一个递归代码示例，但我真的不知道如何根据我的需要进行修改。任何帮助都会非常棒。

递归代码示例

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

Sub PrintV(v)
    For J = 1 To UBound(v): Debug.Print v(J) & " ";: Next J
    Debug.Print
End Sub
Sub test()
    Dim v()
    depth = 4 'adjust
    a = 1
    ReDim v(1 To depth)
    RecurseMe a, v, depth
End Sub

问候

【问题讨论】：

你能重申你的目标吗？你想做什么？
我想将循环数设置为变量。例如在上面的示例中，我使用了 8 个循环，因此输出为 2^8=256。但有时我只需要 2 个。所以输出将是 2x2 矩阵。
它只是填充了我数组中的数据。此数组长度是可变的，因此所有循环都根据每个数组长度运行。
如果你想获得不同数组元素的完全外连接，你可以看看这个问题：link。有范围而不是数组，但很容易适应。无需递归。
@BradNicku，很棒的链接！我在同一个帖子上做了回答。 OP 应该考虑到工作簿的 VBA 记录集连接，并跨所有数组运行笛卡尔叉积 SQL。

标签： excel vba for-loop recursion permutation

【解决方案1】：

对于未来的读者，OP 的需求基本上遵循Cartesian Product，即集合之间所有有序对的数学运算。可以轻松地运行Cross Join SQL 查询或特别是没有任何JOIN 语句的查询来获得结果集。这也称为完全外连接查询。

一些 SQL 引擎（如 SQL Server）使用 CROSS JOIN 语句，其结果集等于每个包含的查询表的乘积行（例如，2*2*2*2*2*2*2*2 = 2^8 = 256）。

在 MS Access（MS Excel 的同级数据库）中，使用定义为两个项目的 8 个数组的表，下面将是交叉连接查询。每个Array表中的item字段都带有配对(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;

设计

输出

Excel 解决方案

因为 VBA 可以通过包括 Excel 的 ODBC Jet 驱动程序在内的相关驱动程序连接到各种 SQL 引擎，所以工作簿可以连接到工作表范围并运行相同的交叉连接查询：

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

【讨论】：

这个解决方案听起来非常简洁和简单，但你能确认[ArraySheet1$A1:A3] 是 Sheet1!A1:A3，[ArraySheet2$A1:A3] 是 Sheet2!A1:A3 。等等？如何修改strSQL 以适应不同的范围？也就是说，构建 strSQL 以供通用使用？
另外，这是否可以在与 C:\Path To\Excel\Workbook.xlsx 连接到 C:\Path To\Excel\ 的同一工作簿上Workbook.xlsx?
@Patrick Yes ArraySheet 是一个命名工作表，您可以在同一个工作表中使用不同的范围。不幸的是，据我所知，ODBC 工作簿连接必须在外部完成，而不是在同一个工作簿上。
感谢@Parfait，我会尝试使用范围，希望它也适用于命名范围！

【解决方案2】：

我将其视为二元问题：

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

【讨论】：

【解决方案3】：

如果您仍然希望修复代码以产生所需的结果。

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

【讨论】：