[练习题][VBA第4期]字符串 首尾相连

ldy

<div class="msgheader">QUOTE:</div><div class="msgborder"><b>以下是引用<i>Luckyguy2008</i>在2007-11-18 0:17:00的发言：</b><br/>不讨论了，我再好好想想<br/><br/>另外，我目前错误的方法98个金币来回也就10毫秒[em04][em04][em04][em04][em04]</div><p></p><p>如此一来，我对自己的结果是否正确，有些担心了，98 个金币我单边来回也要四秒[em04]</p><p>数据少可人工检验，多了就没法了，请用兄帮忙给检测一下结果</p><p>黄色去程，绿色回程</p><br/>

djyjysxxs

<p>再笨不会笨过这个吧[em04]且思维零乱！还是发出来作引玉之用：</p><p>Sub 首尾相连中级()<br/>Dim arr1() As String, arr2()<br/>n = Range("a1").End(xlDown).Row<br/>marr = Range("a1:a" &amp; n)<br/>ReDim arr1(1 To n) As String<br/>i1 = 0<br/>For i = 1 To n<br/>&nbsp; be = Left(marr(i, 1), 1)<br/>&nbsp; en = Right(marr(i, 1), 1)<br/>&nbsp; str1 = ""<br/>&nbsp; str2 = ""<br/>&nbsp; For k = 1 To n<br/>&nbsp;&nbsp;&nbsp; If be = Right(marr(k, 1), 1) Then str1 = str1 &amp; k &amp; ","<br/>&nbsp;&nbsp;&nbsp; If en = Left(marr(k, 1), 1) Then arr1(i) = arr1(i) &amp; k &amp; ","<br/>&nbsp; Next k<br/>&nbsp; If str1 = "" Then<br/>&nbsp;&nbsp;&nbsp;&nbsp; i1 = i1 + 1<br/>&nbsp;&nbsp;&nbsp;&nbsp; ReDim Preserve arr2(1 To i1)<br/>&nbsp;&nbsp;&nbsp;&nbsp; arr2(i1) = i<br/>&nbsp; End If<br/>Next i<br/>Dim arr3() As String<br/>i2 = 0<br/>For i = 1 To UBound(arr2)<br/>t = 1<br/>&nbsp; str1 = arr2(i)<br/>&nbsp; i1 = 0<br/>&nbsp; k = Val(str1)<br/>&nbsp; Do While t &gt; 0<br/>&nbsp; Do While arr1(k) &lt;&gt; ""<br/>&nbsp;&nbsp;&nbsp; k = Split(arr1(k), ",")(i1)<br/>&nbsp;&nbsp;&nbsp; str1 = str1 &amp; "," &amp; k<br/>&nbsp; Loop<br/>&nbsp; i2 = i2 + 1<br/>&nbsp; ReDim Preserve arr3(1 To i2)<br/>&nbsp; myarr = Split(str1, ",")<br/>&nbsp; arr3(i2) = marr(myarr(0), 1)<br/>&nbsp; For ii = 1 To UBound(myarr)<br/>&nbsp;&nbsp;&nbsp;&nbsp; arr3(i2) = arr3(i2) &amp; Right(marr(myarr(ii), 1), Len(marr(myarr(ii), 1)) - 1)<br/>&nbsp; Next ii<br/>&nbsp; Tr = 1<br/>&nbsp; Do While InStr(1, str1, ",")<br/>&nbsp;&nbsp;&nbsp;&nbsp; str1 = Left(str1, InStrRev(str1, ",", Len(str1)) - 1)<br/>&nbsp;&nbsp;&nbsp;&nbsp; k1 = Right(str1, Len(str1) - InStrRev(str1, ",", Len(str1)))<br/>&nbsp;&nbsp;&nbsp;&nbsp; If Right(arr1(k1), Len(k) + 1) &lt;&gt; k &amp; "," Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; k = Mid(arr1(k1), InStr(1, arr1(k1), k) + Len(k &amp; ","), InStr(InStr(1, arr1(k1), k) + Len(k &amp; ",") + 1, arr1(k1), ",") - InStr(1, arr1(k1), k) - Len(k &amp; ","))<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; str1 = str1 &amp; "," &amp; k<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Exit Do<br/>&nbsp;&nbsp;&nbsp;&nbsp; Else<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; k = k1<br/>&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp; Loop<br/>&nbsp; If InStr(1, str1, ",") = 0 Then t = 0<br/>&nbsp; Loop<br/>Next i<br/>[d4].Resize(i2, 1) = Application.Transpose(arr3)<br/>End Sub</p>

Luckyguy2008

<p>最近学习了一下彭希仁老师关于递归的帖子，正好用上</p><p>Option Explicit<br/>Dim Dict_H As New Dictionary, Str_Result As New Dictionary<br/>'全局变量Dict_H是个嵌套的字典，外层Key是字符串头字符，内层Key是该字符所在的行号，比如第5、6行的开头都是“小”，所以Dict_H("小").Keys有5、6两个元素<br/>'全局变量Str_Result，用来存放结果字符串。采用字典是为了避免组合出来的字符串有重复的。比如"ABC"、"CDE"以及"AB"和"BCDE"组合结果是一样的(本题的数据没有这种情况)</p><p>Sub 首尾相连中级()<br/>&nbsp;&nbsp;&nbsp; Dim Data_S, Count As Long, i As Long, Str_H As String, Str_E As String, Dict_E As New Dictionary<br/>&nbsp;&nbsp;&nbsp; [B:B].ClearContents<br/>&nbsp;&nbsp;&nbsp; Count = Range("A65536").End(xlUp).Row&nbsp;&nbsp; 'Count获得字符串数量<br/>&nbsp;&nbsp;&nbsp; Data_S = Range("A1:C" &amp; Count).Value&nbsp;&nbsp;&nbsp; 'Data_S是一个N*3的数组<br/>&nbsp;&nbsp;&nbsp; For i = 1 To Count<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Str_H = Left(Data_S(i, 1), 1)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Str_E = Right(Data_S(i, 1), 1)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Data_S(i, 1) = Left(Data_S(i, 1), Len(Data_S(i, 1)) - 1)&nbsp;&nbsp;&nbsp; 'Data_S第一列存放原始数据去掉尾字符的结果<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Data_S(i, 2) = Str_H&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; 'Data_S第二列存放头字符<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Data_S(i, 3) = Str_E&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; 'Data_S第三列存放尾字符<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If Not Dict_H.Exists(Str_H) Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Set Dict_H(Str_H) = New Dictionary<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Dict_E(Str_E) = 0&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; '生成尾字符的字典<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Dict_H(Str_H)(i) = 0&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; '生成头字符以及该字符对应行号的嵌套字典<br/>&nbsp;&nbsp;&nbsp; Next i<br/>&nbsp;&nbsp;&nbsp; For i = 1 To Count<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If Not Dict_E.Exists(Data_S(i, 2)) Then&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; '判断每个字符串的头字符，如果该字符在尾字符的字典中没有，说明该字符串只能做开头<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Call Combine(Data_S(i, 1), Data_S, Data_S(i, 3), i)&nbsp;&nbsp;&nbsp;&nbsp; '对只能做开头的字符串进行递归调用，生成结果字符串<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp; Next i<br/>&nbsp;&nbsp;&nbsp; Range("B4").Resize(Str_Result.Count, 1) = Application.WorksheetFunction.Transpose(Str_Result.Keys)&nbsp; '结果输出<br/>' Stop<br/>&nbsp;<br/>End Sub</p><p>Sub Combine(ByVal Str As String, ByVal Data, ByVal Str_End, ByVal Del As Long)<br/>'递归函数，Str为目前已经拼接好的字符串；Data是字符串的数组，去掉了已经使用过的字符串；Str_End为当前拼好的字符串的尾字符；Del为最后一次拼接的字符串的行号<br/>'Str_End有2个用途，1是用来找以它开头的字符串；2是如果找到最后一个字符串，需要把它连接到合并的字符串后面<br/>&nbsp;&nbsp;&nbsp; Dim Dict_Temp As Dictionary, i As Long, j As Long, Changed As Boolean<br/>&nbsp;&nbsp;&nbsp; Data(Del, 1) = ""&nbsp;&nbsp; '在Data中删除最后的一个字符串，比如"ABC"和"CBA"，如果不对使用过的删掉，调用过程中会死循环<br/>&nbsp;&nbsp;&nbsp; If Dict_H.Exists(Str_End) Then&nbsp; '判断是否能找到Str_End开头的字符<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Set Dict_Temp = Dict_H(Str_End)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; For i = 0 To Dict_Temp.Count - 1<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; j = Dict_Temp.Keys(i)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If Data(j, 1) &lt;&gt; "" Then&nbsp;&nbsp;&nbsp; '判断所有以Str_End开头的字符串是否已经使用过，如没使用则把这个字符串连结在Str上，继续进行递归调用<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Changed = True&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; '同时把Changed标示为True<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Call Combine(Str &amp; Data(j, 1), Data, Data(j, 3), j)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Next i<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If Changed = False Then '如果Changed还是False，说明可以连接的几个字符串都已经用过了，就就是拼好的一个结果，添加到Str_Result中<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Str = Str &amp; Str_End<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Str_Result(Str) = 0&nbsp;&nbsp;&nbsp;&nbsp; '把结果存到Str_Result字典中，这里只需用到字典的Key，用字典是为了避免重复结果<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp; Else&nbsp;&nbsp;&nbsp; '已经是最后一个字符串了，后面没有可以连接的，把尾字符补上，添加到Str_Result字典中<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Str = Str &amp; Str_End<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Str_Result(Str) = 0<br/>&nbsp;&nbsp;&nbsp; End If<br/>End Sub<br/></p><p><br/></p>

[此贴子已经被作者于2007-11-19 13:16:32编辑过]

ldy

<p>谢谢二位参与，结果都正确，还没来得及细看。</p><p>最近比较注重解题的思路，请二位写一下解题思路。</p><p>便于相互交流。</p>

djyjysxxs

响应号召写出14楼的想法：<br/>1、数组：将原数据存入数组marr；数组arr1用于存放数组marr中每个元素后面可以接的元素所在的位置，如marr(1,1)="专门创"，它的后面可以接的只有"创建VBA"，位于25行，则arr1(1)="25,"，marr(14,1)="建立",它的后面可接的内容分别位于10、11、12,则arr1(14)="10,11,12,",而marr(10,1)="立联系"后面无可接内容，则arr1(10)=""；arr2用于存放marr中只能位于开始位置的元素所在的位置，结果为由1、7、19、24、27构成的数组；arr3用于存放结果字符串<br/>2、程序思路：从arr2中取出起始字符所在的位置A，由A在arr1中循环找到接在它后面的字符所在的位置B，直到一句结束，得到第一句。由这一句向后退一步，看能否接另一个内容，若能取另一个内容，形成第二句，若不能则再向后退，再找。直到所有的可能找完。下一个A。

Luckyguy2008

经测试天堂鼠兄的代码比我的要快[em17]<br/>

ldy

<p>Sub 首尾相连中级3()<br/>'结果输出到B列'''''''''''''''''ldy<br/>&nbsp;&nbsp;&nbsp; Dim aa(), l As Long, i As Long, ed As Long<br/>&nbsp;&nbsp;&nbsp; t = Timer<br/>&nbsp;&nbsp;&nbsp; ed = Range("a1").End(xlDown).Row<br/>&nbsp;&nbsp;&nbsp; Range("b:g").ClearContents<br/>&nbsp;&nbsp;&nbsp; rg = Range("a1").Resize(ed, 7) '建立一个7 列的数组，<br/>&nbsp;&nbsp;&nbsp; '1 原始数据, 2 字头, 3字尾 ，4 下家数量 5 上家数量&nbsp; 6 下家的位置（与天堂鼠思路相同），7 去掉字头的文字<br/>&nbsp;&nbsp;&nbsp; ' 取得字头字尾<br/>&nbsp;&nbsp;&nbsp; For i = 1 To ed<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; rg(i, 2) = Left(rg(i, 1), 1)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; rg(i, 3) = Right(rg(i, 1), 1)<br/>&nbsp;&nbsp;&nbsp; Next</p><p>'<br/>&nbsp;&nbsp;&nbsp; For i = 1 To ed<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; For j = 1 To ed<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If i &lt;&gt; j Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If rg(i, 3) = rg(j, 2) Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; rg(i, 4) = rg(i, 4) + 1&nbsp;&nbsp;&nbsp; '4 下家数量<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; rg(i, 6) = rg(i, 6) &amp; " " &amp; j '6 下家的位置<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If rg(i, 2) = rg(j, 3) Then rg(i, 5) = rg(i, 5) + 1 ' 5 上家数量<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Next</p><p>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If rg(i, 5) &gt; 0 Then '如果有上家<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; rg(i, 7) = Mid(rg(i, 1), 2) '去掉字头<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Else<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; rg(i, 7) = rg(i, 1) '没有上家说明是句头 保留原样<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp; Next</p><p>'&nbsp;&nbsp;&nbsp; Range("a1").Resize(ed, 7) = rg '2激活可看数据结构</p><p>' 数据的各项属性建立完成，在递归的大循环中直接调用，快很多</p><p>&nbsp;</p><p><br/>&nbsp;&nbsp;&nbsp; l = 0<br/>&nbsp;&nbsp;&nbsp; For i = 1 To ed<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If rg(i, 5) = 0 And rg(i, 4) &lt;&gt; 0 Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; TRT1 i, aa, l&nbsp;&nbsp;&nbsp; '递归求出所有 有效组合<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If</p><p>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If rg(i, 5) = 0 And rg(i, 4) = 0 Then '没有上家和下家的说明是独立的句子<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; l = l + 1<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ReDim Preserve aa(1 To l)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; aa(l) = rg(i, 1)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp; Next</p><p>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp; MsgBox Timer - t &amp; " 秒 " &amp; l &amp; " 条"<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; '填表比较费时 大约5-8秒，想看结果请激活</p><p>'&nbsp;&nbsp;&nbsp; Range("h1").Resize(l, 1) = WorksheetFunction.Transpose(aa)</p><p>End Sub</p><p>&nbsp;</p><p>Sub TRT1(Y As Long, aa(), LL As Long)<br/>''''''''''递归过程''''''''''ldy<br/>'''''''初次写递归 效率不理想<br/>&nbsp;&nbsp;&nbsp; Dim j As Long, OL As Long, R7, x As Long<br/>&nbsp;&nbsp;&nbsp; R7 = Split(rg(Y, 6))<br/>&nbsp;&nbsp;&nbsp; For ii = 1 To rg(Y, 4) '下家的数量<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; OL = LL + 1<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; j = R7(ii) '第 ii 个下家的位置<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If rg(j, 4) = 0 Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; LL = LL + 1<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ReDim Preserve aa(1 To LL)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; aa(LL) = rg(Y, 7) &amp; rg(j, 7)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Else<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; TRT1 j, aa, LL<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; aa(LL) = rg(Y, 7) &amp; aa(LL)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If rg(j, 4) &gt; 0 Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; For x = OL To LL<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If InStr(aa(x), rg(Y, 7)) &lt;&gt; 1 Then aa(x) = rg(Y, 7) &amp; aa(x)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Next<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp; Next<br/>End Sub</p><p>&nbsp;</p><p>把三个人的做到一起了<br/></p><br/>

ldy

<p>简单说几句<br/>对于算法和递归我也是初学，因为之前没有这样的需求。</p><p>天堂鼠、2008的思路与我的基本一样，我的代码比天堂鼠快一倍，没别的诀窍<br/>只不过把大循化中要用到内容，提前在小循环中完成，减少了代码重复计算</p><p>为什么2008的慢许多？<br/>1 递归之前没判断， 2008的递归调用90000多次 我的则30000多次<br/>2 字典的读写速度比1维数组慢 2 到3 倍 很简单<br/>记录一条数据 字典要写两次， key 和 item，而 一维数组只有一次<br/>那是不是以后就不用 字典了？ 当然不是。字典查数据要快的多<br/>这两样时间一累加 2008 的比我的慢4倍也就不奇怪了</p><p>当然这都是大思路相同，算法类似的情况下的，技巧、经验上的差别<br/>没什么特别，一两句话说明白了，也就理解了。</p><p>如果算法上更优化，也许还能大幅度提速。但算法和递归，我还相当于小白水平<br/>无法更进一步。 </p><p><br/>专门 给彭老师，和用版 发了信息。希望他们二位 有空指点一二。<br/></p>

Luckyguy2008

谢谢LDY老师的总结，回头慢慢揣摩。<br/><br/>看来字典的使用也需要慎重，有的场合用数组更快。<br/><br/><br/>

[此贴子已经被作者于2007-11-20 11:57:07编辑过]

彭希仁

<p>向各位高手学习了,可以这么说,前期的基础工作做得是相当不错的,非常值得学习,递归方面欠妥.做了很多无用功.递归代码精简如下:</p><p>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; TRT1 i, "", l&nbsp;&nbsp;&nbsp; '递归求出所有 有效组合</p><p></p><p>Sub TRT1(Y, aa, LL As Long)</p><p>Sub TRT1(Y, aa, LL As Long)<br/>&nbsp;&nbsp;&nbsp; Dim j As Long, OL As Long, R7, x As Long<br/>&nbsp;&nbsp;&nbsp; R = Split(rg(Y, 6))&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;'将字附串方式换成数组方式会更科学&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<br/>&nbsp;&nbsp;&nbsp; If rg(Y, 4) = 0 Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; LL = LL + 1<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Cells(LL, 2) = aa &amp; rg(Y, 7)&nbsp;&nbsp;&nbsp; '我是懒了,没有用数组不好意思<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Exit Sub<br/>&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp; For ii = 1 To rg(Y, 4)&nbsp;&nbsp;&nbsp; '下家的数量<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Call TRT1(R(ii), aa &amp; rg(Y, 7), LL)<br/>&nbsp;&nbsp;&nbsp; Next ii<br/>End Sub<br/></p><p></p><p></p><p></p>