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

香川群子

香川组合代码更新：

1. Sub GetCmCnArray()
   
2.     d = ActiveCell.CurrentRegion 'Like Array
   
3.     'a 1 甲 A あ
   
4.     'b 2 乙 B
   
5.     'c 3    C
   
6.    
   
7.     rw = ActiveCell.CurrentRegion.Rows.Count
   
8.     cl = ActiveCell.CurrentRegion.Columns.Count
   
9.    
   
10.     If rw = 1 Or cl = 1 Then MsgBox "未选中数据区域": Exit Sub
    
11.    
    
12.     ReDim c(1, cl)
    
13.     c(0, 0) = rw
    
14.     c(1, 0) = 1
    
15.     For j = cl To 1 Step -1
    
16.         s = ""
    
17.         For i = 1 To rw
    
18.             If d(i, j) <> "" Then s = s & ";" & i
    
19.         Next
    
20.         t = Split(s, ";")
    
21.         For i = 1 To UBound(t)
    
22.             d(i, j) = d(t(i), j)
    
23.         Next
    
24.         For i = UBound(t) + 1 To rw
    
25.             d(i, j) = ""
    
26.         Next
    
27.         c(0, j) = UBound(t)
    
28.         c(1, j) = c(1, 0)
    
29.         c(1, 0) = c(1, 0) * c(0, j)
    
30.     Next
    
31.     n = c(1, 0)
    
32.     If n = 0 Then MsgBox "未正确选择数据区域": Exit Sub
    
33.     If n > 65536 Then MsgBox "结果>65536，停止": Exit Sub
    
34.    
    
35.     ReDim a(n - 1, cl)
    
36.     For i = 0 To n - 1
    
37.         For j = cl To 1 Step -1
    
38.             a(i, j - 1) = d(Int(i / c(1, j)) Mod c(0, j) + 1, j)
    
39.             a(i, cl) = a(i, j - 1) & a(i, cl)
    
40.         Next
    
41.     Next
    
42.    
    
43.     With ActiveCell.Offset(rw + 3)
    
44.         .CurrentRegion = ""
    
45.         .Resize(n, cl + 1) = a
    
46.         For i = 0 To cl - 1
    
47.             .Offset(-1, i) = c(0, i + 1)
    
48.         Next
    
49.         .Offset(-1, cl) = n
    
50.         .Resize(, cl + 1).EntireColumn.AutoFit
    
51.     End With
    
52. End Sub
    

复制代码

数据局域中任意位置可以包含空格，组合时自动排除/忽略空格。

shore0707

大姐帮帮忙啊，小弟看了你的贴就知道你是高手！
请帮帮小弟吧！

http://club.excelhome.net/thread-822546-1-1.html

guzhen9315

香川群子 发表于 2012-2-5 23:34
香川组合代码更新：数据局域中任意位置可以包含空格，组合时自动排除/忽略空格。

虽然看不懂，但还是想通了。

昨晚一躺下，就在想“香川组合”，终于想通了。

谢谢！

香川群子

香川组合代码更新，
计算方式改为彻底数组方式，避免了反复进行int/mod计算定位，速度提高4倍。

1. Sub GetCmCnArray2()
   
2.     d = ActiveCell.CurrentRegion
   
3.     rw = ActiveCell.CurrentRegion.Rows.Count 'rw = UBound(d)
   
4.     cl = ActiveCell.CurrentRegion.Columns.Count 'cl = UBound(d, 2)
   
5.     If rw = 1 Or cl = 1 Then MsgBox "Area not Select !": Exit Sub
   
6.    
   
7.     ReDim r(cl)
   
8.     ReDim x(0)
   
9.     r(0) = x
   
10.     m = 1
    
11.     For j = 1 To cl
    
12.         ReDim x(m * rw)
    
13.         m = 0
    
14.         For i = 1 To rw
    
15.             If d(i, j) <> "" Then
    
16.                 For k = 0 To UBound(r(j - 1))
    
17.                     x(m) = r(j - 1)(k) & d(i, j)
    
18.                     m = m + 1
    
19.                 Next
    
20.             End If
    
21.         Next
    
22.         On Error GoTo ErrExt
    
23.         ReDim Preserve x(m - 1)
    
24.         r(j) = x
    
25.     Next
    
26.     Exit Sub
    
27.    
    
28.     If ActiveCell.Row + rw + 3 + m > 65536 Then
    
29.         MsgBox ">65536 Err!"
    
30.     Else
    
31.         ActiveCell.Offset(rw + 3).Resize(m) = WorksheetFunction.Transpose(x)
    
32.     End If
    
33. ErrExt:
    
34. End Sub

复制代码

香川群子

由于取值方式改变，因此输出结果顺序和以前的代码结果不一致。
经如下修改调整取值顺序，得到一致结果。

1. Sub GetCmCnArray3()
   
2.     Dim rw%, cl%, m&, i%, j%, k%
   
3.     d = ActiveCell.CurrentRegion
   
4.     rw = ActiveCell.CurrentRegion.Rows.Count
   
5.     cl = ActiveCell.CurrentRegion.Columns.Count
   
6.     If rw = 1 Or cl = 1 Then MsgBox "Area not Select !": Exit Sub
   
7.    
   
8.     ReDim r(cl)
   
9.     ReDim x(0)
   
10.     r(cl) = x
    
11.     m = 1
    
12.     For j = cl To 1 Step -1
    
13.         ReDim x(m * rw)
    
14.         m = 0
    
15.         For i = 1 To rw
    
16.             If d(i, j) <> "" Then
    
17.                 For k = 0 To UBound(r(j))
    
18.                     x(m) = d(i, j) & r(j)(k)
    
19.                     m = m + 1
    
20.                 Next
    
21.             End If
    
22.         Next
    
23.         ReDim Preserve x(m - 1)
    
24.         r(j - 1) = x
    
25.     Next
    
26.     Exit Sub
    
27.    
    
28.     If ActiveCell.Row + rw + 3 + m > 65536 Then
    
29.         MsgBox ">65536 Err!"
    
30.     Else
    
31.         ActiveCell.Offset(rw + 3).Resize(m) = WorksheetFunction.Transpose(x)
    
32.     End If
    
33. End Sub
    

复制代码

香川群子

更新获取香川组合的自定义函数代码：

1. Function MN(Rng As Range, k, Optional InsWd = "")
   
2.     d = Rng
   
3.     rw = UBound(d) 'Rng.Rows.Count
   
4.     cl = UBound(d, 2) 'Rng.Columns.Count
   
5.     If IsNumeric(InsWd) And InsWd > cl Then MN = "N> " & cl: Exit Function
   
6.     If rw = 1 Or cl = 1 Then MN = "rw/cl =1 Err! ": Exit Function
   
7.    
   
8.     ReDim c(1, cl)
   
9.     c(0, 0) = rw
   
10.     c(1, 0) = 1
    
11.     For j = cl To 1 Step -1
    
12.         s = ""
    
13.         For i = 1 To rw
    
14.             If d(i, j) <> "" Then s = s & ";" & i
    
15.         Next
    
16.         t = Split(s, ";")
    
17.         For i = 1 To UBound(t)
    
18.             d(i, j) = d(t(i), j)
    
19.         Next
    
20.         For i = UBound(t) + 1 To rw
    
21.             d(i, j) = ""
    
22.         Next
    
23.         c(0, j) = UBound(t)
    
24.         c(1, j) = c(1, 0)
    
25.         c(1, 0) = c(1, 0) * c(0, j)
    
26.     Next
    
27.     n = c(1, 0)
    
28.     If n = 0 Then MN = "n=0 Err! ": Exit Function
    
29.    
    
30.     If k > n Then MN = "> " & n: Exit Function
    
31.    
    
32.     If IsNumeric(InsWd) And InsWd > 0 Then
    
33.         l = InsWd
    
34.         MN = d(Int((k - 1) / c(1, l)) Mod c(0, l) + 1, l)
    
35.         Exit Function
    
36.     Else
    
37.         MN = d(Int((k - 1) / c(1, 1)) Mod c(0, 1) + 1, 1)
    
38.         For l = 2 To cl
    
39.             MN = MN & InsWd & d(Int((k - 1) / c(1, l)) Mod c(0, l) + 1, l)
    
40.         Next
    
41.     End If
    
42. End Function
    

复制代码

更新目的，是组合对象范围中的空白单元格，可被自动忽略。

香川群子

根据序号求组合结果，以及根据组合结果，倒推序号的自定义函数。

1. Function CK(m%, n%, k&) '按组合序号k求组合结果数组输出
   
2.     Dim i%, j%, l%, p%, q&, r&
   
3.     r = k
   
4.     ReDim x(1 To n)
   
5.     For i = 1 To n - 1
   
6.         For j = 1 To m - n + 1
   
7.             q = Application.WorksheetFunction.Combin(m - i - p, m - n - p)
   
8.             If r > q Then r = r - q: p = p + 1 Else l = l + j: Exit For
   
9.         Next
   
10.         x(i) = l
    
11.     Next
    
12.     x(n) = (r - 1) Mod (m - l + 1) + l + 1
    
13.     CK = x
    
14. End Function

复制代码

香川群子

以及根据组合结果，倒推序号的自定义函数。

1. Function CJ&(r, m%) ''已知组合结果求组合序号
   
2.     Dim i%, j%, n%, p%, q&
   
3.     If r.Count > 1 Then
   
4.         ReDim s(m)
   
5.         For i = 1 To r.Count
   
6.             If r(i) <> "" Then s(r(i)) = r(i)
   
7.         Next
   
8.         x = Split(Application.Trim(Join(s)))
   
9.     Else
   
10.         x = Split(r.Text, ",")
    
11.     End If
    
12.     n = UBound(x)
    
13.     p = 1
    
14.     For i = 0 To n - 1
    
15.         For j = p To x(i) - 1
    
16.             q = Application.Combin(m - j, m - j - n + i)
    
17.             CJ = CJ + q
    
18.         Next
    
19.         p = x(i) + 1
    
20.     Next
    
21.     CJ = CJ + x(n) - x(n - 1)
    
22. End Function

复制代码

香川群子

之前的代码：

1. Function CJ0(r, m%) '已知组合结果求组合序号
   
2.     Dim i%, j%, n%, p%, q&
   
3.     x = Split(r, ",")
   
4.     n = UBound(x): p = 1
   
5.     For i = 0 To n - 1
   
6.         For j = p To x(i) - 1
   
7.             q = Application.Combin(m - j, m - n + i - j)
   
8.             CJ = CJ + q
   
9.         Next
   
10.         p = x(i) + 1
    
11.     Next
    
12.     CJ = CJ + x(n) - x(n - 1)
    
13. End Function

复制代码

1. Function CJ1(r, m%) '已知组合结果求组合序号
   
2.     Dim i%, j%, n%, p%, q&
   
3.     If r.Count > 1 Then
   
4.         If r.Column = 1 Then
   
5.             x = Application.Transpose(r)
   
6.         Else
   
7.             x = Application.Transpose(Application.Transpose(r))
   
8.         End If
   
9.     Else
   
10.         x = Split("," & r.Text, ",")
    
11.     End If
    
12.     n = UBound(x): p = 1
    
13.     For i = 1 To n - 1
    
14.         For j = p To x(i) - 1
    
15.             q = Application.Combin(m - j, m - n + i - j)
    
16.             CJ = CJ + q
    
17.         Next
    
18.         p = x(i) + 1
    
19.     Next
    
20.     CJ = CJ + x(n) - x(n - 1)
    
21. End Function

复制代码

香川群子

可以求：
从任意序号位置开始，到任意序号位置结束 的组合结果的代码:

1. Sub GetCombinArray()
   
2.     Dim AC&, i&, j%, l%, m%, n%, r&, s&, f&, p%, q&
   
3.     tms = Timer
   
4.    
   
5.     m = [a1].End(4).Row:    n = [b1]:    AC = Application.Combin(m, n):    k = [b2]
   
6.     s = IIf([b4] = 0 Or [b4] > AC, 1, [b4]): f = IIf([b5] = 0 Or [b5] > AC, AC, [b5])
   
7.     arr = [a1].Resize(m)
   
8.    
   
9.     ReDim a%(1 To n)
   
10.     ReDim b%(1 To n)
    
11.    
    
12.     r = s
    
13.     For i = 1 To n - 1
    
14.         For j = 1 To m - n + 1
    
15.             q = Application.Combin(m - i - p, m - n - p)
    
16.             If r > q Then r = r - q: p = p + 1 Else l = l + j: Exit For
    
17.         Next
    
18.         a(i) = l 'a(i) = i 'brr(i, 1) = i
    
19.         b(i) = i + m - n 'brr(i, 2) = i + m - n
    
20.     Next
    
21.     a(n) = (r - 1) Mod (m - l + 1) + l + 1
    
22.     b(n) = m
    
23.    
    
24.     ReDim crr(s To f, m)
    
25.     For i = s To f
    
26. '        crr(i, j) = a(j)   'crr(i, j) = brr(j, 1)
    
27.         For j = 1 To n
    
28.             If k = m Then
    
29.                 crr(i, 0) = crr(i, 0) & "," & arr(a(j), 1)
    
30.                 crr(i, a(j)) = arr(a(j), 1)
    
31.             ElseIf k = n Then
    
32.                 crr(i, 0) = crr(i, 0) & "," & arr(a(j), 1)
    
33.                 crr(i, j) = arr(a(j), 1)
    
34.             Else
    
35.                 crr(i, 0) = crr(i, 0) & kc & arr(a(j), 1)
    
36.             End If
    
37.         Next j
    
38.         If k = m Or k = n Then crr(i, 0) = Mid(crr(i, 0), 2) Else crr(i, 0) = Mid(crr(i, 0), Len(kc) + 1)
    
39.         
    
40.         a(n) = a(n) + 1 'brr(n, 1) = brr(n, 1) + 1
    
41.         If a(n) > b(n) Then 'If brr(n, 1) > brr(n, 2) Then
    
42.             For j = n - 1 To 1 Step -1
    
43.                 If a(j) < b(j) Then l = j: Exit For 'If brr(j, 1) < brr(j, 2) Then l = j: Exit For
    
44.             Next j
    
45.             If l > 0 Then
    
46.                 a(l) = a(l) + 1 'brr(l, 1) = brr(l, 1) + 1
    
47.                 For j = l + 1 To n
    
48.                     a(j) = a(j - 1) + 1 'brr(j, 1) = brr(j - 1, 1) + 1
    
49.                 Next j
    
50.             End If
    
51.         End If
    
52.     Next
    
53.    
    
54.     [b3] = AC
    
55.     [b6] = Timer - tms
    
56.     If f - s > 65535 Then Exit Sub
    
57.    
    
58.     [a1].EntireColumn.AutoFit
    
59.     [d1].CurrentRegion.Clear
    
60.     If k = m Then
    
61.         [d1].Resize(f - s + 1, m + 1) = crr
    
62.         [e1].Resize(1, m).ColumnWidth = [a1].ColumnWidth
    
63.     ElseIf k = n Then
    
64.         [d1].Resize(f - s + 1, n + 1) = crr
    
65.         [e1].Resize(1, n).ColumnWidth = [a1].ColumnWidth
    
66.     Else
    
67.         [d1].Resize(f - s + 1) = crr
    
68.     End If
    
69.     [d1].EntireColumn.AutoFit
    
70.    
    
71.     [b7] = Timer - tms
    
72.     [b8] = [b7] - [b6]
    
73.    
    
74. End Sub
    

复制代码