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

香川群子

本来我这个自定义函数，每一次计算过程中，工作表函数也就用一次，问题不大。

不过，如果是因为其他原因需要反复调用的话，确实不如常数赋值来得快。

cumulonimbus

群子小姐，能说说你的组合的思路吗？
For i = 1 To n - 1
        For j = 1 To m - n + 1
            t = Application.WorksheetFunction.Combin(m - i - p, m - n - p) '按组合公式排列
            If k > t + 0.1 Then
                k = k - t
                p = p + 1
            Else
                l = l + j
                Exit For
            End If
        Next
这个思路解释得不清，能否麻烦群子小姐详加解释，让我等菜鸟好好学习一下。

soillssol

裙子小姐你的函数太实用了。强烈收藏。{:soso_e179:}

香川群子

更新排列代码：
(第4参数分隔符，增加分列功能)

1. Function PN(Rng As Range, n%, k&, Optional InsWd = "") 'k番目の排列結果を出力,
   
2.     m% = Rng.Count '元素数
   
3.     PAM& = Application.WorksheetFunction.Permut(m, n)
   
4.     If k > PAM Then PN = "K> " & PAM: Exit Function
   
5.     If IsNumeric(InsWd) And InsWd > n Then PN = "Cl> " & n: Exit Function
   
6.    
   
7.     Dim i%, j%
   
8.     Dim s As New Collection
   
9.     For i = 1 To m
   
10.         s.Add Rng.Cells(i)
    
11.     Next
    
12.    
    
13.     For i = 1 To n - 1
    
14.             j = Int((k - 1) / Application.WorksheetFunction.Permut(m - i, n - i)) Mod (m - i + 1) + 1
    
15.             If IsNumeric(InsWd) And InsWd = i Then PN = s(j): Exit Function Else PN = PN & s(j) & InsWd: s.Remove j
    
16.     Next
    
17.     If IsNumeric(InsWd) And InsWd = i Then PN = s((k - 1) Mod (m - n + 1) + 1) Else PN = PN & s((k - 1) Mod (m - n + 1) + 1)
    
18. End Function

复制代码

香川群子

更新组合代码：
(第4参数分隔符，增加分列功能)

1. Function CN(Rng As Range, n%, k&, Optional InsWd = "") 'k番目の組合結果を出力,
   
2.     m% = Rng.Count '元素数
   
3.     CAM& = Application.WorksheetFunction.Combin(m, n)
   
4.     If k > CAM Then CN = "K> " & CAM: Exit Function
   
5.     If IsNumeric(InsWd) And InsWd > n Then CN = "N> " & n: Exit Function
   
6.    
   
7.     Dim i%, j%, l%, t%, p%
   
8.     Dim s As New Collection
   
9.     For i = 1 To m
   
10.         s.Add Rng.Cells(i)
    
11.     Next
    
12.    
    
13.     For i = 1 To n - 1
    
14.         For j = 1 To m - n + 1
    
15.             t = Application.WorksheetFunction.Combin(m - i - p, m - n - p)
    
16.             If k > t Then k = k - t: p = p + 1 Else l = l + j: Exit For
    
17.         Next
    
18.         If IsNumeric(InsWd) And InsWd = i Then CN = s(l): Exit Function Else CN = CN & s(l) & InsWd
    
19.     Next
    
20.     If IsNumeric(InsWd) And InsWd = i Then CN = s((k - 1) Mod (m - l + 1) + l + 1) Else CN = CN & s((k - 1) Mod (m - l + 1) + l + 1)
    
21. End Function

复制代码

香川群子

追加按列循环组合代码:

1. Function MN(Rng As Range, k&, Optional InsWd = "") '組合順K番目の行列ﾃﾞｰﾀ組合結果を出力,
   
2.     d = Rng '元ﾃﾞｰﾀ、例え:1列目3行;2列目2行;3列目4行...
   
3.     r% = Rng.Columns.Count '列数
   
4.     If IsNumeric(InsWd) And InsWd > r Then MN = "N> " & r: Exit Function
   
5.    
   
6.     Dim i%, j%, l%
   
7.     ReDim c&(r, 1)
   
8.     c(0, 1) = 1
   
9.     For i = r To 1 Step -1
   
10.         For j = Rng.Rows.Count To 1 Step -1
    
11.             If d(j, i) <> "" Then c(i, 0) = j: Exit For
    
12.         Next
    
13.         If c(i, 0) > c(0, 0) Then c(0, 0) = c(i, 0)
    
14.         
    
15.         c(i, 1) = c(0, 1)
    
16.         c(0, 1) = c(0, 1) * c(i, 0)
    
17.     Next
    
18.     If k > c(0, 1) Then MN = "> " & c(0, 1): Exit Function
    
19.    
    
20.     If IsNumeric(InsWd) And InsWd > 0 Then
    
21.         MN = d(Int((k - 1) / c(InsWd, 1)) Mod c(InsWd, 0) + 1, InsWd)
    
22.     Else
    
23.         MN = d(Int((k - 1) / c(1, 1)) Mod c(1, 0) + 1, 1)
    
24.         For l = 2 To r
    
25.             MN = MN & InsWd & d(Int((k - 1) / c(l, 1)) Mod c(l, 0) + 1, l)
    
26.         Next
    
27.     End If
    
28. End Function

复制代码

香川群子

直接一次性输出排列结果的代码：

1. Sub GetPermutArray()
   
2.     tms = Timer
   
3.    
   
4.     m = [a1].End(4).Row
   
5.     arr = [a1].Resize(m)
   
6.     n = [b1]
   
7.     kc = [b2]
   
8.    
   
9.     ReDim a(1 To n)
   
10.     ReDim b(1 To m)
    
11.     For i = 1 To n - 1
    
12.         a(i) = i
    
13.         b(i) = 1
    
14.     Next i
    
15.     a(n) = n
    
16.    
    
17.     AP = WorksheetFunction.Permut(m, n)
    
18.    
    
19. '    Dim crr() As Long
    
20.     ReDim crr(1 To AP, 1 To m + 1)
    
21.     For i = 1 To AP
    
22.         If kc = m Then
    
23.             crr(i, m + 1) = "'" & arr(a(1), 1)
    
24.             crr(i, a(1)) = arr(a(1), 1)
    
25.         ElseIf kc = n Then
    
26.             crr(i, 1) = arr(a(1), 1)
    
27.         Else
    
28.             crr(i, 1) = "'" & arr(a(1), 1)
    
29.         End If
    
30.         
    
31.         For j = 2 To n
    
32. '            crr(i, j) = a(j)
    
33.             If kc = m Then
    
34.                 crr(i, m + 1) = crr(i, m + 1) & "," & arr(a(j), 1)
    
35.                 crr(i, a(j)) = arr(a(j), 1)
    
36.             ElseIf kc = n Then
    
37.                 crr(i, j) = arr(a(j), 1)
    
38.             Else
    
39.                 crr(i, 1) = crr(i, 1) & kc & arr(a(j), 1)
    
40.             End If
    
41.         Next j
    
42.         
    
43.         If a(n) < m Then
    
44.             For j = a(n) + 1 To m
    
45.                 If b(j) = 0 Then
    
46.                     a(n) = j
    
47.                     GoTo NxtJ
    
48.                 End If
    
49.             Next
    
50.         End If
    
51.         'a(n)=m
    
52.         For j = n - 1 To 1 Step -1
    
53.             b(a(j)) = 0
    
54.             If a(j) < m Then
    
55.                 For jj = a(j) + 1 To m
    
56.                     If b(jj) = 0 Then
    
57.                         a(j) = jj
    
58.                         b(a(j)) = 1
    
59.                         k = j + 1
    
60.                         GoTo NxtK
    
61.                     End If
    
62.                 Next
    
63.             End If
    
64.         Next
    
65. NxtK:
    
66.         If k = 0 Then GoTo NxtJ
    
67.         For k = k To n
    
68.             For l = 1 To m
    
69.                 If b(l) = 0 Then
    
70.                     a(k) = l
    
71.                     If k < n Then b(l) = 1
    
72.                     Exit For
    
73.                 End If
    
74.             Next
    
75.         Next
    
76. NxtJ:
    
77.     Next
    
78.    
    
79.     [b3] = AP
    
80.     [b4] = Timer - tms
    
81.     If AP > 65536 Then Exit Sub
    
82.    
    
83.     [a1].EntireColumn.AutoFit
    
84.     [d1].CurrentRegion.Clear
    
85.     If kc = m Then
    
86.         [d1].Resize(AP, m + 1) = crr
    
87.         [d1].Resize(1, m).ColumnWidth = [a1].ColumnWidth
    
88.         [d1].Offset(0, m).EntireColumn.AutoFit
    
89.     ElseIf kc = n Then
    
90.         [d1].Resize(AP, n) = crr
    
91.         [d1].Resize(1, n).ColumnWidth = [a1].ColumnWidth
    
92.     Else
    
93. '        ReDim Preserve crr(1 To AP, 1 To 1)
    
94.         [d1].Resize(AP) = crr
    
95.         [d1].EntireColumn.AutoFit
    
96.     End If
    
97.     [b5] = Timer - tms
    
98.     [b6] = [b5] - [b4]
    
99.    
    
100.    
     
101. End Sub
     

复制代码

香川群子

直接一次性输出组合结果的代码：

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

复制代码

香川群子

直接一次性生成各列循环组合的代码：

1. Sub GetCmCnArray()
   
2.     tms = Timer
   
3.     d = ActiveCell.CurrentRegion 'Like Array
   
4.     'a 1 甲 A あ
   
5.     'b 2 乙 B
   
6.     'c 3     C
   
7.    
   
8.     rw = ActiveCell.CurrentRegion.Rows.Count
   
9.     cl = ActiveCell.CurrentRegion.Columns.Count
   
10.    
    
11.     ReDim c(1, cl)
    
12.     c(0, 0) = rw
    
13.     c(1, 0) = 1
    
14.     For j = cl To 1 Step -1
    
15.         For i = 1 To rw
    
16.             If d(i, j) = "" Then Exit For
    
17.         Next
    
18.         c(0, j) = i - 1
    
19.         c(1, j) = c(1, 0)
    
20.         c(1, 0) = c(1, 0) * c(0, j)
    
21.     Next
    
22.     n = c(1, 0)
    
23.    
    
24.     ReDim a(n - 1, cl)
    
25.     For i = 0 To n - 1
    
26.         For j = cl To 1 Step -1
    
27.             a(i, j - 1) = d(Int(i / c(1, j)) Mod c(0, j) + 1, j)
    
28.             a(i, cl) = a(i, j - 1) & a(i, cl)
    
29.         Next
    
30.     Next
    
31.    
    
32.     If n > 65536 Then MsgBox Timer - tms: Exit Sub
    
33.     With ActiveCell.Offset(rw + 3)
    
34.         .CurrentRegion = ""
    
35.         .Resize(n, cl + 1) = a
    
36.         .Resize(, cl + 1).EntireColumn.AutoFit
    
37.         For i = 0 To cl - 1
    
38.             .Offset(-1, i) = c(0, i + 1)
    
39.         Next
    
40.         .Offset(-1, cl) = n
    
41.     End With
    
42. End Sub
    

复制代码

香川群子

配合规划求解的有效位精确逼近代码：

1. Sub myGoalSeek()
   
2.     t = Range("A2")
   
3.     t = Left(t, Len(t) - 1)
   
4.     Range("A2") = t
   
5.     For i = 1 To 15
   
6.         t = Range("A2")
   
7.         s = Range("G2")
   
8.         If s > 0 Then
   
9.             For j = 1 To 9
   
10.                 Range("A2") = t & j
    
11.                 If Range("G2") > 0 And Range("G2") < s Then
    
12.                     s = Range("G2")
    
13.                 Else
    
14.                     Range("A2") = t & j - 1
    
15.                     Exit For
    
16.                 End If
    
17.             Next
    
18.         Else
    
19.             For j = 1 To 9
    
20.                 Range("A2") = t & j
    
21.                 If Range("G2") < 0 And Range("G2") > s Then
    
22.                     s = Range("G2")
    
23.                 Else
    
24.                     Range("A2") = t & j - 1
    
25.                     Exit For
    
26.                 End If
    
27.             Next
    
28.         End If
    
29.     Next
    
30. End Sub
    

复制代码