[已解决]请老师指正全排列VBA代码（写了一段VBA，实现不了预期效果）

kandhong

老师：
      我想请教的是：全排列组合问题。
      具体思路如下：
      ①"数据区"有01至12三行数据。
      ②让"数据区"三行数据在"生成区"进行全排列组合。
      ③本例中已有VBA，但实现不了预期效果，让各位老师指正！
   
      谢谢老师！！
       请老师修改VBA代码（写了一段VBA，实现不了预期效果）.rar (8.75 KB, 下载次数: 8)

2014-4-9 10:28 上传

点击文件名下载附件
      

最佳答案

月排行榜 / 总排行榜

芐雨

2014-4-9 16:37

1. Sub 三码组合()
   
2.     Dim d As Object, ar, br, cr, arr, brr(), s$, i, j, k, m, n
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     ar = [b4:m4]: br = [b5:m5]: cr = [b6:m6]
   
5.     ReDim arr(1 To 2744, 1 To 3)
   
6.     For i = 1 To 12
   
7.         For j = 1 To 12
   
8.             For k = 1 To 12
   
9.                 s = ar(1, i) & br(1, j) & cr(1, k)
   
10.                 If Not d.exists(s) Then
    
11.                     m = m + 1
    
12.                     d(s) = m
    
13.                     arr(m, 1) = ar(1, i): arr(m, 2) = br(1, j): arr(m, 3) = cr(1, k)
    
14.                 End If
    
15.             Next
    
16.         Next
    
17.     Next
    
18.     ReDim brr(1 To m, 1 To 3)
    
19.     For i = 1 To UBound(arr)
    
20.         If Len(arr(i, 1)) > 0 And Len(arr(i, 2)) > 0 And Len(arr(i, 3)) > 0 And _
    
21.            arr(i, 1) <> arr(i, 2) And arr(i, 2) <> arr(i, 3) And arr(i, 1) <> arr(i, 3) Then
    
22.             n = n + 1
    
23.             brr(n, 1) = arr(i, 1): brr(n, 2) = arr(i, 2): brr(n, 3) = arr(i, 3)
    
24.         End If
    
25.     Next
    
26.     [o4:q2745].ClearContents
    
27.     [o4].Resize(n, 3) = brr
    
28.     Set d = Nothing
    
29. End Sub
    

复制代码

Set d = CreateObject("scripting.dictionary") 这句没有，你的字典根本就没有创建出来

跳转到最佳答案楼层

sayhi1984

帮顶，好难......

芐雨

1. Sub 三码组合()
   
2.     Dim d As Object, ar, br, cr, arr, brr(), s$, i, j, k, m, n
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     ar = [b4:m4]: br = [b5:m5]: cr = [b6:m6]
   
5.     ReDim arr(1 To 2744, 1 To 3)
   
6.     For i = 1 To 12
   
7.         For j = 1 To 12
   
8.             For k = 1 To 12
   
9.                 s = ar(1, i) & br(1, j) & cr(1, k)
   
10.                 If Not d.exists(s) Then
    
11.                     m = m + 1
    
12.                     d(s) = m
    
13.                     arr(m, 1) = ar(1, i): arr(m, 2) = br(1, j): arr(m, 3) = cr(1, k)
    
14.                 End If
    
15.             Next
    
16.         Next
    
17.     Next
    
18.     ReDim brr(1 To m, 1 To 3)
    
19.     For i = 1 To UBound(arr)
    
20.         If Len(arr(i, 1)) > 0 And Len(arr(i, 2)) > 0 And Len(arr(i, 3)) > 0 And _
    
21.            arr(i, 1) <> arr(i, 2) And arr(i, 2) <> arr(i, 3) And arr(i, 1) <> arr(i, 3) Then
    
22.             n = n + 1
    
23.             brr(n, 1) = arr(i, 1): brr(n, 2) = arr(i, 2): brr(n, 3) = arr(i, 3)
    
24.         End If
    
25.     Next
    
26.     [o4:q2745].ClearContents
    
27.     [o4].Resize(n, 3) = brr
    
28.     Set d = Nothing
    
29. End Sub
    

复制代码

Set d = CreateObject("scripting.dictionary") 这句没有，你的字典根本就没有创建出来

kandhong

芐雨 发表于 2014-4-9 16:37
Set d = CreateObject("scripting.dictionary") 这句没有，你的字典根本就没有创建出来

芐雨老师：
     您的大作已收悉，正解！！
     您的指正，让我学到了很多，感谢！！