Excel VBA中的递归函数使用GoTo，数组中的字符组合

Question

我想在 Excel VBA 中创建一个 recursive 函数，而不使用 nested 循环。我使用GoTo 来执行此操作，因为我认为它与 For 循环等相比非常快。PROBLEM: 问题是第一个标签即'a' 没有执行所有iterations 并且没有返回所需的组合所以.从给定的数组 'arr' 应该有 39 combinations 但只返回 14。我尝试更改一些代码行，总迭代“iNum”返回 39，但不是 39 个组合（从'a' 开始的组合总是丢失）。请帮忙，谢谢。

Function rec_n()
    Dim a As Integer, b As Integer, c As Integer
    Dim aSize As Integer, iNum As Integer
    Dim myStr As String
    'Dim arr As Variant
    Dim arr(5) As String

    'arr = Array("a", "b", "c", "d")
    arr(0) = "a"
    arr(1) = "b"
    arr(2) = "c"
    'arr(3) = "d"

    aSize = 3 - 1
    'a = 0: b = 0: c = 0

a:  If a < aSize Then
        myStr = myStr & arr(a) & ", "
        a = a + 1: iNum = iNum + 1


b:      If b < aSize Then
            myStr = myStr & arr(a) & arr(b) & ", "
            b = b + 1: iNum = iNum + 1


c:          If c < aSize Then
                'On Error Resume Next
                myStr = myStr & arr(a) & arr(b) & arr(c) & ", "
                c = c + 1: iNum = iNum + 1

                GoTo c
            Else
                c = 0
                'MsgBox c
            End If
            GoTo b
        Else
            b = 0
            'MsgBox b
        End If
        GoTo a
    End If

EndFunc:
    MsgBox iNum & vbLf & myStr
    Range("a2").Value = myStr
End Function

已编辑： 该代码仅产生以下组合：

a，ba，bba，bbb，bb，bca，bcb，b，ca，cba，cbb，cb，cca，ccb，

这 39 个预期在哪里：

a，b，c，aa，ab，ac，ba，bb，bc，ca，cb，cc，aaa，aab，aac，aba，abb， abc，aca，acb，acc，咩，bab，bac，bba，bbb，bbc，bca，bcb，bcc，caa， 出租车，cac，cba，cbb，cbc，cca，ccb，ccc，

Answer 1

这里是一个 goto-free 递归方法：

Function StringsFrom(A As Variant, Optional maxlen As Variant) As Variant
    'returns a 0-based array of all strings of length <= maxlen
    'with elements drawn from A
    'A is assumed to be 0-based array
    'If maxlen is missing then it is taken to be the number of elements in A

    Dim strings As Variant
    Dim newstrings As Variant
    Dim i As Long, j As Long, k As Long, m As Long, n As Long

    If IsMissing(maxlen) Then maxlen = 1 + UBound(A)
    m = UBound(A)
    If maxlen < 1 Then Exit Function

    If maxlen = 1 Then
        'basis case -- return a copy of A - coerced to be strings if needed
        ReDim newstrings(0 To m)
        For i = 0 To m
            newstrings(i) = CStr(A(i))
        Next i
    Else
        strings = StringsFrom(A, maxlen - 1)
        n = UBound(strings)
        ReDim newstrings(0 To n + (m + 1) ^ maxlen)
        'first copy strings to newstrings:
        For i = 0 To n
            newstrings(i) = strings(i)
        Next i

        k = n + 1 'points to current index in newstrings
        'now -- load up the rest using a nested loop:
        For i = 0 To m
            For j = n + 1 - (m + 1) ^ (maxlen - 1) To n
                newstrings(k) = A(i) & strings(j)
                k = k + 1
            Next j
        Next i
    End If
    StringsFrom = newstrings
End Function

例如maxlen = 4 和 A 有 5 个字符串，它会首先找到所有长度为 maxlen - 1 = 3 的字符串，然后将字符附加到长度为 完全 的字符串上 3. 我不得不做一点算术以使索引恰到好处。

这是一些测试代码：

Sub test()
    Dim start As Double, elapsed As Double, A As Variant, B As Variant

    A = Array("a", "b", "c")
    B = StringsFrom(A)
    MsgBox Join(B, " ") & vbCrLf & 1 + UBound(B) & " strings"

    A = Array("a", "b", "c", "d", "e", "f", "g")
    start = Timer
    B = StringsFrom(A)
    elapsed = Timer - start
    MsgBox Round(elapsed, 2) & " seconds to process " & 1 + UBound(B) & " strings"
End Sub

第一个测试正确地给出了 3 + 9 + 27 = 39 个字符串，第二个测试（在我的机器上）给出了消息：“0.68 秒来处理 960799 个字符串”。当我增加A 更多时，我会在时间成为问题之前耗尽内存。

ON EDIT：这是一种非递归方法。它比递归方法慢，但不会出现内存不足的问题。它基于这样的想法，例如，如果你的字母是“abc”然后你可以查看例如这些字母中长度为 4 的字符串作为以 3 为底的数字（=Len("abc")），因此枚举它们只需从 0 到 3^4 -1 = 80，将每个数字转换为以 3 为底，然后使用对应关系 `0 "a", 1 "b" 等）：

Sub Enumerate(letters As String, maxlen As Long, Optional display As Boolean = True)
    'letters is assumed to have no repeated characters
    Dim i As Long, j As Long, n As Long, q As Long, r As Long
    Dim counter As Long
    Dim s As String
    Dim A As Variant

    n = Len(letters)
    ReDim A(0 To n - 1)

    For i = 1 To n
        A(i - 1) = Mid(letters, i, 1)
    Next i

    For i = 1 To maxlen
        For j = 0 To n ^ i - 1
            s = ""
            q = j
            If q = 0 Then
                s = A(0)
            Else
                Do While q > 0
                    r = q Mod n
                    q = Int(q / n)
                    s = A(r) & s
                Loop
            End If
            s = String(i - Len(s), A(0)) & s
            counter = counter + 1
            If display Then Debug.Print s
        Next j
    Next i
    Debug.Print counter
End Sub

测试如下：

Sub test2()
    Dim start As Double, elapsed As Double
    Enumerate "abc", 3
    start = Timer
    Enumerate "abcdefghijklmnopqrstuvwxyz", 5, False
    elapsed = Timer - start
    Debug.Print Round(elapsed, 2)
End Sub

测试的时间部分的输出：显示（在我的机器上）循环遍历长度

VBA 是一种解释型语言。我认为它是环绕太阳系的好工具。如果你想探索星系——使用 C。如果你想探索其他星系——希望量子计算机能够工作。

进一步编辑：为了好玩，我写了一个不同版本的Enumerate。它比上一个版本快大约 33%，并且每秒可以循环生成近一百万个字符串（至少在我的笔记本电脑上是这样）。它仍然基于将字符串视为基数 n = length(letters) 中的数字，但模拟了从 1 个数字到下一个数字的加 1，并使用一个数组来查找哪个字符是由“加一个”到一个字母产生的：

Sub Enumerate2(letters As String, maxlen As Long, Optional display As Boolean = True)
    'letters is assumed to have no repeated characters
    'prints all letter combos of length <= maxlen
    'this one simulates the process of adding one to a string

    Dim i As Long, j As Long, k As Long, n As Long, p As Long
    Dim carry As Boolean
    Dim counter As Long
    Dim s As String
    Dim num As Variant
    Dim Successor(127) As String, Z As String, digit As String

    n = Len(letters)
    For i = 1 To n - 1
        Successor(Asc(Mid(letters, i, 1))) = Mid(letters, i + 1, 1)
    Next i
    Z = Mid(letters, 1, 1) 'the "zero" of the base-n system
    Successor(Asc(Mid(letters, n, 1))) = Z

    For i = 1 To maxlen
        ReDim num(1 To i) 'used to count from 0 to n^i - 1 in base n
        For k = 1 To i
            num(k) = Z
        Next k
        For j = 0 To n ^ i - 1
            'get current s
            s = Join(num, "")
            counter = counter + 1
            'now add 1 to num
            carry = True
            p = i 'points to rightmost "digit"
            Do While p > 0 And carry
                digit = Successor(Asc(num(p)))
                If digit <> Z Then carry = False
                num(p) = digit
                p = p - 1
            Loop
            'the real code would go here:
            If display Then Debug.Print s
        Next j
    Next i
    Debug.Print counter
End Sub