[已解决]一个排列组合都VBA

manyfen

求助.rar (6.72 KB, 下载次数: 31)

2015-5-25 16:40 上传

点击文件名下载附件


请问如何才能用VBA实现这5行数据的排列组合？每一行一个数字。
要求：每一个组合都没有重复的数字。
例如：37245、37246、39456等等。谢谢。

详见附件。

最佳答案

月排行榜 / 总排行榜

香川群子

2015-5-26 17:48

上代码和注释：

1. 
   
2. Dim sj, a(9), b(), d, k&, m&, n&
   
3. '定义递归需要的公用变量：
   
4. ' 存放工作表数据区域的二维数组sj
   
5. ' 记录数字是否重复的数组a
   
6. ' 存放组合结果的数组b
   
7. ' 用于删选排序后不重复结果的字典d
   
8. ' 组合结果序号k
   
9. ' 原始数据元素最大个数m (此处为最大行数)
   
10. ' 原始数据列数n
    
11. 
    
12. Sub MultiColumnCombin() 'by kagawa 代码主过程
    
13.     Dim tms#
    
14.     tms = Timer
    
15.    
    
16.     sj = [a1].CurrentRegion
    
17.     m = UBound(sj): n = UBound(sj, 2)
    
18.    
    
19.     k = m ^ n '计算组合结果最大可能数k
    
20.     ReDim b(k, 1 To n) '据此定义存放组合结果的数组b
    
21.     Set d = CreateObject("Scripting.Dictionary") '建立字典d
    
22.    
    
23.     k = 0: Call dgMN(1) 'k初始化 然后调用递归过程
    
24.    
    
25.     [a1].Offset(m + 2, n).CurrentRegion = "" '清空输出区域
    
26.     [a1].Offset(m + 2).Resize(k, n) = b         '输出不重复组合结果
    
27.     [a1].Offset(m + 2, n + 1).Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
    
28.                                                               '输出数字排序后的不重复组合结果
    
29. 
    
30.     MsgBox Format(Timer - tms, "0.000s ") & k & "/" & d.Count
    
31.     '程序结束、对话框显示：程序耗时/组合结果总数k/排序不重复个数
    
32. End Sub
    
33. 
    
34. Sub dgMN(j&) '递归算法过程
    
35.     Dim i&, l&, t
    
36.     For i = 1 To m '遍历本列j列各行
    
37.         t = sj(i, j): If t = "" Then Exit For '如果该行元素为空则退出
    
38.         If a(t) = "" Then '如果该数字未被使用则继续 / 否则跳过
    
39.             a(t) = t '在数组a中标记该数字t已使用
    
40.             b(k, j) = t '在结果数组b的对应列中记录该数字t
    
41.             If j = n Then '如果组合个数达到n个则完成本次组合
    
42.                 k = k + 1 '组合结果k+1
    
43.                 For l = 1 To n - 1
    
44.                     b(k, l) = b(k - 1, l) '复制、继承相同内容到下一行
    
45.                 Next
    
46.                 d(Join(a, "")) = "" '合并数组a中的结果得到从小到大排序的组合结果、用字典去重复
    
47.             Else '如组合个数<n 则继续递归
    
48.                 Call dgMN(j + 1) 'j+1即可进入下一列
    
49.             End If
    
50.             a(t) = "" '本次递归计算后、退出时需要把数组a中的记录也清空，以便下一次新的组合可以使用
    
51.         End If
    
52.     Next
    
53. End Sub
    

复制代码

以上，注释已经很详细了。

跳转到最佳答案楼层

白开水的微笑

看不懂，这5行东西是啥意思

manyfen

依次取每行一个数字进行组合

qh8600

manyfen 发表于 2015-5-25 17:28
依次取每行一个数字进行组合

百度一下，有很多排列组合的代码，自己改改就行

grf1973

1. Sub tt()
   
2.     Dim w(), d, arr$()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     a1 = [a1:c1]
   
5.     a2 = [a2:c2]
   
6.     a3 = [a3:e3]
   
7.     a4 = [a4:e4]
   
8.     a5 = [a5:e5]
   
9.     For Each b1 In a1
   
10.         For Each b2 In a2
    
11.             For Each b3 In a3
    
12.                 For Each b4 In a4
    
13.                     For Each b5 In a5
    
14.                         ReDim w(9)
    
15.                         w(b1) = b1: w(b2) = b2: w(b3) = b3: w(b4) = b4: w(b5) = b5
    
16.                         x = Join(w, "")
    
17.                         If Len(x) = 5 Then d(x) = ""
    
18.     Next: Next: Next: Next: Next
    
19.     Set d1 = CreateObject("scripting.dictionary")
    
20.     For Each x In d.keys
    
21.         PaiLie x, "", arr      '递归实现字符串的全排列，输出到arr
    
22.         For Each y In arr
    
23.             d1(y) = ""
    
24.         Next
    
25.     Next
    
26.     [a10].Resize(d.count) = Application.Transpose(d.keys)
    
27.     [b10].Resize(d1.count) = Application.Transpose(d1.keys)
    
28. End Sub
    
29. '递归实现字符串的全排列
    
30. Sub PaiLie(x, ByRef a As String, ByRef arr() As String, Optional ByRef count As Long)
    
31.     n = Len(x)
    
32.     If Len(a) = n Then
    
33.         count = count + 1
    
34.         ReDim Preserve arr(1 To count)
    
35.         arr(count) = a
    
36.         Exit Sub
    
37.     End If
    
38.     For i = 1 To n
    
39.         If InStr(a, Mid(x, i, 1)) = 0 Then PaiLie x, a & Mid(x, i, 1), arr, count
    
40.     Next i
    
41. End Sub
    

复制代码

grf1973

请看附件。A列是五行各取一个数无重复后的结果，B列是对A列各数全排列的结果。

香川群子

白开水的微笑 发表于 2015-5-25 16:47
看不懂，这5行东西是啥意思

楼主问题应该这么理解：

一、数据
有 5 行数据；
每一行含有个数不等的数字；
每一行中的数字不重复，但各行之间可以有相同数(重复数)。

二、需求
各行抽取一个数字进行组合得到一个5位数，
但必须保证这其中不含重复数。


…………
把行列转置一下，这个问题就是典型的【香川多列组合】问题：
① 有n列、各列中含有不同数量的元素，如： m1、m2、m3、……

② 各列中任选1个元素得到n个元素的组合结果，组合结果总数=m1*m2*m3*……
    【特例：如果各列元素个数相同=m，则组合结果总数k=m^n】

③ 上述组合结果需要排除元素重复的组合。


…………
该问题用我写的递归代码做，很简单的。

香川群子

先上附件

香川群子

上代码和注释：

1. 
   
2. Dim sj, a(9), b(), d, k&, m&, n&
   
3. '定义递归需要的公用变量：
   
4. ' 存放工作表数据区域的二维数组sj
   
5. ' 记录数字是否重复的数组a
   
6. ' 存放组合结果的数组b
   
7. ' 用于删选排序后不重复结果的字典d
   
8. ' 组合结果序号k
   
9. ' 原始数据元素最大个数m (此处为最大行数)
   
10. ' 原始数据列数n
    
11. 
    
12. Sub MultiColumnCombin() 'by kagawa 代码主过程
    
13.     Dim tms#
    
14.     tms = Timer
    
15.    
    
16.     sj = [a1].CurrentRegion
    
17.     m = UBound(sj): n = UBound(sj, 2)
    
18.    
    
19.     k = m ^ n '计算组合结果最大可能数k
    
20.     ReDim b(k, 1 To n) '据此定义存放组合结果的数组b
    
21.     Set d = CreateObject("Scripting.Dictionary") '建立字典d
    
22.    
    
23.     k = 0: Call dgMN(1) 'k初始化 然后调用递归过程
    
24.    
    
25.     [a1].Offset(m + 2, n).CurrentRegion = "" '清空输出区域
    
26.     [a1].Offset(m + 2).Resize(k, n) = b         '输出不重复组合结果
    
27.     [a1].Offset(m + 2, n + 1).Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
    
28.                                                               '输出数字排序后的不重复组合结果
    
29. 
    
30.     MsgBox Format(Timer - tms, "0.000s ") & k & "/" & d.Count
    
31.     '程序结束、对话框显示：程序耗时/组合结果总数k/排序不重复个数
    
32. End Sub
    
33. 
    
34. Sub dgMN(j&) '递归算法过程
    
35.     Dim i&, l&, t
    
36.     For i = 1 To m '遍历本列j列各行
    
37.         t = sj(i, j): If t = "" Then Exit For '如果该行元素为空则退出
    
38.         If a(t) = "" Then '如果该数字未被使用则继续 / 否则跳过
    
39.             a(t) = t '在数组a中标记该数字t已使用
    
40.             b(k, j) = t '在结果数组b的对应列中记录该数字t
    
41.             If j = n Then '如果组合个数达到n个则完成本次组合
    
42.                 k = k + 1 '组合结果k+1
    
43.                 For l = 1 To n - 1
    
44.                     b(k, l) = b(k - 1, l) '复制、继承相同内容到下一行
    
45.                 Next
    
46.                 d(Join(a, "")) = "" '合并数组a中的结果得到从小到大排序的组合结果、用字典去重复
    
47.             Else '如组合个数<n 则继续递归
    
48.                 Call dgMN(j + 1) 'j+1即可进入下一列
    
49.             End If
    
50.             a(t) = "" '本次递归计算后、退出时需要把数组a中的记录也清空，以便下一次新的组合可以使用
    
51.         End If
    
52.     Next
    
53. End Sub
    

复制代码

以上，注释已经很详细了。