使用GoTo,来自数组的字符组合的Excel VBA中的recursion函数

我想在Excel VBA创build一个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个:

aa,ab,ac,ba,bb,bc,ca,cb,cc,aaa,aab,aac,aba,abb,abc,aca,acb,acc,baa,bab,bac,bba, bbb,bbc,bca,bcb,bcc,caa,cab,cac,cba,cbb,cbc,cca,ccb,ccc,

这里是一个无gotorecursion的方法:

 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 = 4A有5个string,它将首先查找长度<= maxlen - 1 = 3所有string,然后将这些字符粘贴到长度正好为 3的string上。我必须做一些算术运算来获得指数恰到好处。

这里是一些testing代码:

 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 

第一个testing正确地给出了3 + 9 + 27 = 39个string,第二个testing(在我的机器上)给出了“0.68秒处理960799个string”的消息。 当我增加更多的时间之前,我用完内存是一个问题。

编辑:这是一个非recursion的方法。 它比recursion方法慢,但不会出现内存不足的问题。 这是基于这样的想法,如果你的字母是“ABC”,那么你可以从这些字母中查看长度为4的string作为基数为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 

testing像:

 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 

testing的时间部分的输出:显示从小于5的长度的小写字母的string中循环所有(超过1230万个)string需要(在我的机器上)大约18秒。有些改进是可能的,但是你将无法获得从粗体字中抽取长string所需的速度。

VBA是一种解释型语言。 我认为这是摆在太阳系周围的好工具。 如果你想探索星系 – 使用C.如果你想探索其他星系 – 希望量子计算机可以工作。

进一步编辑:为了好玩,我写了一个不同版本的Enumerate 。 它比上一个版本快33%,并且可以每秒产生近百万个string(至less在我的平均笔记本电脑上)。 它仍然基于string作为基数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