求排列组合结果的自定义函数

香川群子

zzq0101 发表于 2012-4-22 13:15
有点曲高和寡吧！

呵呵，自己玩也行。

贴上代码，就当做了个备份。以后自己查起来也方便些。

香川群子

求不重复排列的更新。效率更高一些。

1. Sub GetPermutUnique()
   
2.     tms = Timer
   
3.     Dim AP, AC, i%, j%, k%, l%, m%, n%, p%, q%, r%, s&, t%, u%, v%, w&
   
4.     m = [a1].End(4).Row:    n = [b1]
   
5.    
   
6.     ReDim a%(1 To n)
   
7.     ReDim b%(1 To n)
   
8.     ReDim c%(1 To m)
   
9.    
   
10.     trr = [a1].Resize(m)
    
11.     [a1].Resize(m).Sort [a1], 1, , , 2
    
12.     arr = [a1].Resize(m)
    
13.     [a1].Resize(m) = trr
    
14.     c(m) = m + 1
    
15.     For i = m - 1 To 1 Step -1
    
16.         If arr(i, 1) = arr(i + 1, 1) Then c(i) = c(i + 1) Else c(i) = i + 1
    
17.     Next
    
18.    
    
19.     For i = 1 To n
    
20.         a(i) = i
    
21.         b(n - i + 1) = c(m - i + 1) - 1
    
22.     Next
    
23.    
    
24.     ReDim crr(n + 1, 0)
    
25.     For i = 1 To 32767
    
26. '        crr(i, j) = arr(a(j), 1)
    
27.         ReDim d(2, n)
    
28.         l = 0
    
29.         For j = 1 To n
    
30.             For k = 1 To n
    
31.                 If d(0, k) = "" Or d(0, k) = arr(a(j), 1) Then Exit For
    
32.             Next
    
33.             If k > l Then l = k
    
34.             d(0, k) = arr(a(j), 1): d(1, k) = d(1, k) + 1
    
35.         Next
    
36.         ReDim Preserve d(2, l)
    
37.         
    
38.         For j = 1 To l
    
39.             t = d(1, j): p = j
    
40.             For k = j + 1 To l
    
41.                 If d(1, k) < t Then
    
42.                     t = d(1, k): p = k
    
43.                 End If
    
44.             Next
    
45.             If p > j Then
    
46.                 d(0, 0) = d(0, p): d(1, 0) = d(1, p)
    
47.                 d(0, p) = d(0, j): d(1, p) = d(1, j)
    
48.                 d(0, j) = d(0, 0): d(1, j) = d(1, 0)
    
49.             End If
    
50.         Next
    
51.         
    
52.         d(2, 1) = d(1, 1)
    
53.         s = d(1, 1)
    
54.         For j = 2 To l
    
55.             d(2, j) = d(2, j - 1) + d(1, j)
    
56.             If d(1, j) > s Then s = d(1, j)
    
57.         Next
    
58.         s = Application.Permut(n, n - s)
    
59.         
    
60.         r = 0: ReDim y(n, r)
    
61.         For j = 1 To l - 1
    
62.             For k = 1 To d(1, j)
    
63.                 x = y
    
64.                 ReDim y(n, s)
    
65.                 t = 0
    
66.                 For p = 0 To r
    
67.                     For q = n - d(1, j) + k To 1 Step -1
    
68.                         If x(q, p) = d(0, j) Or q = 1 Then
    
69.                             For u = q To n - d(1, j) + k
    
70.                                 If x(u, p) = "" Then
    
71.                                     For v = 1 To n
    
72.                                         If x(v, p) <> "" Then y(v, t) = x(v, p)
    
73.                                     Next
    
74.                                     y(u, t) = d(0, j): t = t + 1
    
75.                                 End If
    
76.                             Next
    
77.                             Exit For
    
78.                         End If
    
79.                     Next
    
80.                 Next
    
81.                 r = t - 1
    
82.                 ReDim Preserve y(n, r)
    
83.             Next
    
84.         Next
    
85.         
    
86.         ReDim Preserve crr(n + 1, w + r)
    
87.         For j = 0 To r
    
88.             For k = 1 To n
    
89. '                crr(k, w + j) = y(k, j)
    
90.                 crr(k, w + j) = IIf(y(k, j) = "", d(0, l), y(k, j))
    
91. '                crr(k, w + j) = IIf(y(k, j) = "", "_", y(k, j))
    
92.                 crr(0, w + j) = crr(0, w + j) & "," & crr(k, w + j)
    
93.             Next
    
94.             crr(0, w + j) = "'" & Mid(crr(0, w + j), 2)
    
95.             crr(n + 1, w + j) = i
    
96.         Next
    
97.         w = w + r + 1
    
98.         
    
99.     '__________________________
    
100.         a(n) = c(a(n))
     
101. Chk:
     
102.         If a(n) > b(n) Then
     
103.             For j = 1 To n
     
104.                 If a(j) > b(j) Then l = j - 1: Exit For
     
105.             Next j
     
106.             If l > 0 Then
     
107.                 a(l) = c(a(l))
     
108.                 For j = l + 1 To n
     
109.                     a(j) = a(j - 1) + 1
     
110.                     If a(j) > b(j) Then If a(1) > b(1) Then GoTo Ext Else GoTo Chk
     
111.                 Next j
     
112.                 GoTo Chk
     
113.             End If
     
114.         End If
     
115.     Next
     
116. Ext:
     
117.     [b7] = "":    [b8] = "":    [d1].CurrentRegion = ""
     
118.     On Error Resume Next
     
119.     AP = WorksheetFunction.Permut(m, n)
     
120.     AC = WorksheetFunction.Combin(m, n)
     
121.     [b3] = i & "/" & AC & "/" & w & "/" & i * WorksheetFunction.Permut(n, n) & "/" & AP
     
122.     [b6] = Timer - tms
     
123.     If w + 1 > 65536 Then Exit Sub
     
124.    
     
125.     [d1].CurrentRegion = ""
     
126.     [d1].Resize(w, n + 2) = Application.Transpose(crr)
     
127.     [d1].EntireColumn.AutoFit
     
128.     [e1].Resize(1, n).EntireColumn.AutoFit
     
129.     [d1].Offset(, n + 1).ColumnWidth = 8.38
     
130. '    [d1].CurrentRegion.Sort [d1], 1, , , 2
     
131.    
     
132.     [b7] = Timer - tms
     
133.     [b8] = [b7] - [b6]
     
134.    
     
135. End Sub
     

复制代码

aragorn_meng

佩服佩服，群子老师很厉害！
请教您一个问题，如何能输出可重复元素的不同组合结果呢，翻遍您的代码也没有找到。我对VBA和算法都不太了解，还望赐教，先行谢过！

香川群子

aragorn_meng 发表于 2012-9-25 18:29
佩服佩服，群子老师很厉害！
请教您一个问题，如何能输出可重复元素的不同组合结果呢，翻遍您的代码也没有 ...

请举例说明。

只要有明确规则，都可以做到。

aragorn_meng

感谢群子老师的回复，规则比较简单，有44个文本元素，取3个元素进行组合，不用考虑元素顺序，在组合中允许元素重复，但不允许组合重复。
也就是输出函数的COMBIN(44+3-1,3)结果，VBA研究了几天也没弄明白，还请群子老师帮忙，多谢。

彭希仁

代码太长了一些，用递归的话，可以精简到比较少。

在FOR里面用 ActiveCell.CurrentRegion.Cells(1).Row + 会影响速度，

香川群子

彭希仁 发表于 2012-9-27 10:52
代码太长了一些，用递归的话，可以精简到比较少。

在FOR里面用 ActiveCell.CurrentRegion.Cells(1).Row  ...

是的。用递归代码会很简单：

1. 
   
2. Dim sj, jg(), m, n, k
   
3. Sub 香川组合递归()
   
4.     sj = [a1].CurrentRegion: m = UBound(sj): n = UBound(sj, 2): Amn = m ^ n
   
5.     If Amn > 65536 Then Exit Sub Else ReDim jg(Amn, n): k = 0
   
6.     Call mndg("", 0)
   
7.     [a1].offset(, n + 3).CurrentRegion = "": [a1].offset(, n + 1) = Amn: [a1].offset(, n + 3).Resize(Amn, n + 1) = jg
   
8. End Sub
   
9. Sub mndg(s$, t%)
   
10.     If t = n Then
    
11.         p = Split(s, ";")
    
12.         For j = 1 To n
    
13.             jg(k, j) = sj(p(j), j)
    
14.             jg(k, 0) = jg(k, 0) & ";" & sj(p(j), j)
    
15.         Next
    
16.         jg(k, 0) = Mid(jg(k, 0), 2): k = k + 1: Exit Sub
    
17.     End If
    
18.     For j = 1 To m
    
19.         If sj(j, t + 1) <> "" Then Call mndg(s & ";" & j, t + 1)
    
20.     Next j
    
21. End Sub

复制代码

香川群子

aragorn_meng 发表于 2012-9-25 20:44
感谢群子老师的回复，规则比较简单，有44个文本元素，取3个元素进行组合，不用考虑元素顺序，在组合中允许元 ...

组合递归代码，稍加修改即可：

1. Dim sj, jg(), m, n, k
   
2. Sub 元素可重复组合递归()
   
3.     tms = Timer
   
4.     m = [a1].End(4).Row
   
5.     sj = [a1].Resize(m)
   
6.     n = [b1]
   
7.     AC = WorksheetFunction.Combin(m + n - 1, n)
   
8.     ReDim jg(AC, n)
   
9.     k = 0
   
10.     Call cfzhdg("", 1, 0)
    
11.     [b3] = AC
    
12.     [d1].CurrentRegion = ""
    
13.     [d1].Resize(AC, n + 1) = jg
    
14.     [d1].Resize(, n + 1).EntireColumn.AutoFit
    
15.     MsgBox Timer - tms
    
16. End Sub
    
17. Sub cfzhdg(s$, i, t%)
    
18.     If t = n Then
    
19.         p = Split(s, ",")
    
20.         For j = 1 To n
    
21.             jg(k, j) = sj(p(j), 1)
    
22.             jg(k, 0) = jg(k, 0) & "," & sj(p(j), 1)
    
23.         Next
    
24.         jg(k, 0) = Mid(jg(k, 0), 2): k = k + 1: Exit Sub
    
25.     End If
    
26.     For j = i To m
    
27.         Call cfzhdg(s & "," & j, j, t + 1)
    
28.     Next j
    
29. End Sub
    

复制代码

元素可重复组合递归.rar (17.96 KB, 下载次数: 81)

2012-9-27 20:24 上传

点击文件名下载附件

香川群子

aragorn_meng 发表于 2012-9-25 18:29
佩服佩服，群子老师很厉害！
请教您一个问题，如何能输出可重复元素的不同组合结果呢，翻遍您的代码也没有 ...

47楼已经给出了通用递归代码。

44取3的组合共有15180个结果。

0.5秒以内计算并输出所有结果。

aragorn_meng

香川群子 发表于 2012-9-27 20:32
47楼已经给出了通用递归代码。

44取3的组合共有15180个结果。

多谢群子老师的帮忙呵，太厉害了，您代码我再慢慢研究，非常感谢！