多条件排列组合

学不完用不尽

说明：本想在“香川群子”大师的代码基础上进行修改，没能成功。特邀请“香川群子”大师帮忙。
根据设定的条件，对数据进行排列组合。
要求参见附件：
多条件排列组合.rar (24.21 KB, 下载次数: 106)

2016-1-3 16:55 上传

点击文件名下载附件

完美程序见26楼。
http://club.excelhome.net/forum. ... 481&pid=8547485

学不完用不尽

勉强修改成功，输出结果基本正确，请“香川群子”大师雅正，谢谢！

1. Option Explicit
   
2. Dim sj1, sj2, sj3, jg(), k&, L&, m&, n&
   
3. Sub Combin_kagawa2()
   
4.     Dim sj, i, kk, j
   
5.         With Sheets("排列组合")
   
6.             sj = .Range("a1").CurrentRegion.Offset(1)
   
7.             sj3 = .Range("o2:r2")
   
8.             ReDim sj2(1 To 1000, 1 To UBound(sj))
   
9.             L = 0: i = 0
   
10.             Do
    
11.                 i = i + 1: n = sj(i, 1)
    
12.                 If n Then
    
13.                     L = L + 1: k = 0
    
14.                     Do
    
15.                        If sj(i, 2) <> "" Then
    
16.                             ReDim sj1(1 To UBound(sj, 2))
    
17.                             For j = 1 To UBound(sj, 2)
    
18.                                 If sj(i, j + 1) = "" Then Exit For Else sj1(j) = sj(i, j + 1)
    
19.                             Next
    
20.                             m = j - 1
    
21.                             Call dgZH("", 0, 1)
    
22.                         End If
    
23.                         If sj(i + 1, 1) <> "" Then Exit Do Else i = i + 1
    
24.                     Loop Until i = UBound(sj)
    
25.                     If k > kk Then kk = k
    
26.                 End If
    
27.             Loop Until i = UBound(sj)
    
28.             m = kk: n = L: k = 0
    
29.             .[a2].Offset(UBound(sj) + 7).CurrentRegion = ""
    
30.             .[a2].Offset(UBound(sj) + 7).Resize(m, n) = sj2
    
31.             ReDim jg(60000, 0)
    
32.             Call dgMN("", 1)
    
33.             If k = 0 Then MsgBox "无此排列组合，请重新设置条件！": Exit Sub
    
34.             .[w2].CurrentRegion = ""
    
35.             .[w2] = "共有" & k & "种组合"
    
36.             .[w3].Resize(k) = jg
    
37.         End With
    
38. End Sub
    
39. 
    
40. Sub dgZH(r$, i%, t%)
    
41.     Dim j%, jj, sjgw
    
42.     For j = i + 1 To m - n + t
    
43.        If t < n Then
    
44.        sjgw = Val(Right(Mid(r & "," & sj1(j), 2), 1))
    
45.        For jj = 1 To 4
    
46.        If sjgw = sj3(1, jj) Then
    
47.        Call dgZH(r & "," & sj1(j), j, t + 1)
    
48.        End If
    
49.        Next jj
    
50.        Else
    
51.        sjgw = Val(Right(Mid(r & "," & sj1(j), 2), 1))
    
52.        For jj = 1 To 4
    
53.        If sjgw = sj3(1, jj) Then
    
54.        k = k + 1
    
55.        sj2(k, L) = Mid(r & "," & sj1(j), 2)
    
56.        End If
    
57.        Next jj
    
58.        End If
    
59.     Next
    
60. End Sub
    
61. 
    
62. Sub dgMN(r$, j%)
    
63.     Dim i%, jj, sjgw, sjgw1, sjgw2
    
64.     For i = 1 To m
    
65.         If sj2(i, j) <> "" Then
    
66.         If j < n Then
    
67.         Call dgMN(r & "," & sj2(i, j), j + 1)
    
68.         Else
    
69.         sjgw = Mid(r, 2) & "," & sj2(i, j)
    
70.         sjgw1 = Split(sjgw, ",")
    
71.         For jj = 0 To UBound(sjgw1)
    
72.         sjgw2 = sjgw2 & "," & Right(sjgw1(jj), 1)
    
73.         Next jj
    
74.         sjgw2 = Mid(sjgw2, 2)
    
75.         If InStr(sjgw2, sj3(1, 1)) > 0 And InStr(sjgw2, sj3(1, 2)) > 0 Then
    
76.         If InStr(sjgw2, sj3(1, 3)) > 0 And InStr(sjgw2, sj3(1, 4)) > 0 Then
    
77.         jg(k, 0) = sjgw
    
78.         k = k + 1
    
79.         End If
    
80.         End If
    
81.         sjgw2 = ""
    
82.         End If
    
83.         End If
    
84.     Next
    
85. End Sub

复制代码

x007file

学习一下，多谢分享

学不完用不尽

添加动态条件：

1. Option Explicit
   
2. Dim sj1, sj2, sj3, jg(), k&, L&, m&, n&, col
   
3. Sub Combin_kagawa2()
   
4.     Dim sj, i, kk, j
   
5.         With Sheets("排列组合")
   
6.             sj = .Range("a1").CurrentRegion.Offset(1)
   
7.             col = .[q2]
   
8.             sj3 = .Range(.[o4], .Cells(4, 14 + col))
   
9.             ReDim sj2(1 To 1000, 1 To UBound(sj))
   
10.             L = 0: i = 0
    
11.             Do
    
12.                 i = i + 1: n = sj(i, 1)
    
13.                 If n Then
    
14.                     L = L + 1: k = 0
    
15.                     Do
    
16.                        If sj(i, 2) <> "" Then
    
17.                             ReDim sj1(1 To UBound(sj, 2))
    
18.                             For j = 1 To UBound(sj, 2)
    
19.                                 If sj(i, j + 1) = "" Then Exit For Else sj1(j) = sj(i, j + 1)
    
20.                             Next
    
21.                             m = j - 1
    
22.                             Call dgZH("", 0, 1)
    
23.                         End If
    
24.                         If sj(i + 1, 1) <> "" Then Exit Do Else i = i + 1
    
25.                     Loop Until i = UBound(sj)
    
26.                     If k > kk Then kk = k
    
27.                 End If
    
28.             Loop Until i = UBound(sj)
    
29.             m = kk: n = L: k = 0
    
30.             .[a2].Offset(UBound(sj) + 7).CurrentRegion = ""
    
31.             .[a2].Offset(UBound(sj) + 7).Resize(m, n) = sj2
    
32.             ReDim jg(60000, 0)
    
33.             Call dgMN("", 1)
    
34.             If k = 0 Then MsgBox "无此排列组合，请重新设置条件！": Exit Sub
    
35.             .[w2].CurrentRegion = ""
    
36.             .[w2] = "共有" & k & "种组合"
    
37.             .[w3].Resize(k) = jg
    
38.         End With
    
39. End Sub
    
40. 
    
41. Sub dgZH(r$, i%, t%)
    
42.     Dim j%, jj, sjgw
    
43.     For j = i + 1 To m - n + t
    
44.        If t < n Then
    
45.        sjgw = Val(Right(Mid(r & "," & sj1(j), 2), 1))
    
46.        For jj = 1 To col
    
47.        If sjgw = sj3(1, jj) Then
    
48.        Call dgZH(r & "," & sj1(j), j, t + 1)
    
49.        End If
    
50.        Next jj
    
51.        Else
    
52.        sjgw = Val(Right(Mid(r & "," & sj1(j), 2), 1))
    
53.        For jj = 1 To col
    
54.        If sjgw = sj3(1, jj) Then
    
55.        k = k + 1
    
56.        sj2(k, L) = Mid(r & "," & sj1(j), 2)
    
57.        End If
    
58.        Next jj
    
59.        End If
    
60.     Next
    
61. End Sub
    
62. 
    
63. Sub dgMN(r$, j%)
    
64.     Dim i%, jj, sjgw, sjgw1, sjgw2
    
65.     For i = 1 To m
    
66.         If sj2(i, j) <> "" Then
    
67.         If j < n Then
    
68.         Call dgMN(r & "," & sj2(i, j), j + 1)
    
69.         Else
    
70.         sjgw = Mid(r, 2) & "," & sj2(i, j)
    
71.         sjgw1 = Split(sjgw, ",")
    
72.         For jj = 0 To UBound(sjgw1)
    
73.         sjgw2 = sjgw2 & "," & Right(sjgw1(jj), 1)
    
74.         Next jj
    
75.         sjgw2 = Mid(sjgw2, 2)
    
76.         If col = 2 Then
    
77.         If InStr(sjgw2, sj3(1, 1)) > 0 And InStr(sjgw2, sj3(1, 2)) > 0 Then
    
78.         jg(k, 0) = sjgw
    
79.         k = k + 1
    
80.         End If
    
81.         ElseIf col = 3 Then
    
82.         If InStr(sjgw2, sj3(1, 1)) > 0 And InStr(sjgw2, sj3(1, 2)) > 0 Then
    
83.         If InStr(sjgw2, sj3(1, 3)) > 0 Then
    
84.         jg(k, 0) = sjgw
    
85.         k = k + 1
    
86.         End If
    
87.         End If
    
88.         ElseIf col = 4 Then
    
89.         If InStr(sjgw2, sj3(1, 1)) > 0 And InStr(sjgw2, sj3(1, 2)) > 0 Then
    
90.         If InStr(sjgw2, sj3(1, 3)) > 0 And InStr(sjgw2, sj3(1, 4)) > 0 Then
    
91.         jg(k, 0) = sjgw
    
92.         k = k + 1
    
93.         End If
    
94.         End If
    
95.         ElseIf col = 5 Then
    
96.         If InStr(sjgw2, sj3(1, 1)) > 0 And InStr(sjgw2, sj3(1, 2)) > 0 Then
    
97.         If InStr(sjgw2, sj3(1, 3)) > 0 And InStr(sjgw2, sj3(1, 4)) > 0 Then
    
98.         If InStr(sjgw2, sj3(1, 5)) > 0 Then
    
99.         jg(k, 0) = sjgw
    
100.         k = k + 1
     
101.         End If
     
102.         End If
     
103.         End If
     
104.         End If
     
105.         sjgw2 = ""
     
106.         End If
     
107.         End If
     
108.     Next
     
109. <span style="line-height: 1.5;">End Sub</span>

复制代码

香川群子

代码不需要那么复杂：

1. Dim sj(), jg(), m&, n&, k&
   
2. Sub test() 'by kagawa 2106/1/5
   
3.     Dim i&, j&, l&, cl&, r&, t&, tms#
   
4.     tms = Timer
   
5.    
   
6.     m = [a1].End(4).Row
   
7.     ReDim a&(9)
   
8.     For i = 2 To m
   
9.         a(Cells(i, 1)) = 1 '提取尾数
   
10.     Next
    
11.    
    
12.     cl = [a1].End(2).Column
    
13.     n = WorksheetFunction.Sum([b1].Resize(, cl - 1))
    
14.     If n <> 5 Then MsgBox "n <> 5 Err !": Exit Sub
    
15.    
    
16.     m = 7
    
17.     ReDim sj(1 To m, 1 To n)
    
18.     n = 0: r = 1
    
19.     For j = 2 To cl '遍历数据区各列
    
20.         For l = 1 To Cells(1, j) '按第1行指定有效次数重复
    
21.             n = n + 1: i = 0 '行位置 i 初始化、列数=n
    
22.             For k = 1 To 7
    
23.                 t = k + (j - 2) * 7 '生成数据表
    
24.                 If a(t Mod 10) Then i = i + 1: sj(i, n) = t '符合尾数的则提取
    
25.             Next
    
26.             r = r * i '理论组合次数
    
27.         Next
    
28.     Next
    
29.     [b11].Resize(m, n) = sj '输出整理后的数据表
    
30.    
    
31.     ReDim jg(r, n) '存放结果的数组
    
32.    
    
33.     k = 0: Call dgMN(1) '调用香川多列组合的递归过程
    
34. 
    
35.     MsgBox Format(Timer - tms, "0.000s ") & k
    
36.     [a1].Offset(, n + 3).CurrentRegion.Offset(1) = ""
    
37.     [a1].Offset(1, n + 3).Resize(k, n + 1) = jg
    
38.    
    
39. End Sub
    
40. 
    
41. Sub dgMN(j&)
    
42.     Dim i&, l&
    
43.     For i = 1 To m
    
44.         If sj(i, j) = 0 Then Exit For '本列为空时退出
    
45.         If sj(i, j) > jg(k, j - 1) Then '确保每个组合中的数值为升序且不重复
    
46.             jg(k, j) = sj(i, j)
    
47.             If j = n Then
    
48.                 k = k + 1: jg(k - 1, 0) = k
    
49.                 For l = 1 To n - 1
    
50.                     jg(k, l) = jg(k - 1, l)
    
51.                 Next
    
52.             Else
    
53.                 Call dgMN(j + 1)
    
54.             End If
    
55.         End If
    
56.     Next
    
57. End Sub
    

复制代码

学不完用不尽

香川群子 发表于 2016-1-5 16:42
代码不需要那么复杂：

貌似遗漏了一个条件：结果中必须包含所有的尾数，缺一不可。

香川群子

组合完成后，增加一个检查不重复尾数个数是否符合要求的代码。

学不完用不尽

香川群子 发表于 2016-1-6 11:06
组合完成后，增加一个检查不重复尾数个数是否符合要求的代码。

非常感谢！OK！！完美！！！
看看你写的代码，再比对一下我修改的代码，天壤之别。
能否再提一个小小的请求：利用和值（最小和值和最大和值之间，和值指的是一组组合中的所有数字之和）对组合完成后的结果进一步进行筛选。

香川群子

当然可以。你自己先举个例子吧。

学不完用不尽

香川群子 发表于 2016-1-6 23:32
当然可以。你自己先举个例子吧。

就是有效组合必须在一定的和值范围内。


烦请修改一下代码，谢谢！
CombinTest-2.rar (20.36 KB, 下载次数: 50)

2016-1-7 11:05 上传

点击文件名下载附件