[已解决]挑选数据组合

mmc998

Book六码组合.rar (7.37 KB, 下载次数: 38)

2014-2-14 20:03 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

香川群子

2014-2-15 18:54

1. 
   
2. Dim sj&(), sj2$(), jc&(), jg$(), c&, m1&, n1&, m2&, n2&, k&, cnt&, tms#, cnt2&
   
3. Sub kagawa()
   
4.     tms = Timer
   
5.     [a1].CurrentRegion.Offset(1) = ""
   
6.    
   
7.     m1 = 9: n1 = 3
   
8.     k = Application.Combin(m1, n1) 'k=84
   
9.     ReDim sj&(1 To k, 1 To n1)  'Get Combin(9,3)
   
10.     ReDim sj2$(1 To k) 'Get Combin(9,3)
    
11.     k = 0: Call dgZH1("", 0, 1)
    
12.    
    
13.     ReDim jc&(1 To m1)
    
14.    
    
15.     m2 = k: n2 = 6: c = 2
    
16.     k = Application.Combin(m2, n2) 'k=406,481,544
    
17.     cnt = 10 ^ 4: ReDim jg$(1 To cnt, 1 To 1)
    
18.     k = 1: Call dgZH2("", 0, 1) 'k=122,220
    
19.    
    
20.     Cells(Cells.Rows.Count, 1).End(3).Offset(1).Resize(k - 1) = jg
    
21.     MsgBox Format(Timer - tms, "0.000s ") & Format([a1].End(4).Row - 1, "#,##0")
    
22.    
    
23. End Sub
    
24. Sub dgZH1(s$, i&, t&)
    
25.     Dim j&, l&
    
26.     For j = i + 1 To m1 - n1 + t
    
27.         If t = n1 Then
    
28.             k = k + 1
    
29.             For l = 1 To n1 - 1
    
30.                 sj(k, l) = Mid(s, l, 1)
    
31.             Next
    
32.             sj(k, n1) = j
    
33.             sj2(k) = s & j
    
34.         Else
    
35.             Call dgZH1(s & j, j, t + 1)
    
36.         End If
    
37.     Next
    
38. End Sub
    
39. Sub dgZH2(s$, i&, t&)
    
40.     Dim j&, l&
    
41. '    cnt2 = cnt2 + 1 '1,474,590
    
42.    
    
43.     For j = i + 1 To m2 - n2 + t
    
44.         For l = 1 To n1
    
45.             If jc(sj(j, l)) = c Then Exit For
    
46.         Next
    
47.         
    
48.         If l = n1 + 1 Then
    
49.             If t = n2 Then
    
50.                 jg(k, 1) = Mid(s, 2) & " " & sj2(j)
    
51.                 If k = cnt Then
    
52.                     Cells(Cells.Rows.Count, 1).End(3).Offset(1).Resize(cnt) = jg
    
53.                     Application.StatusBar = Format([a1].End(4).Row - 1, "#,##0") & Format(Timer - tms, " 0.000s ") & s & sj2(j)
    
54.                     k = 1
    
55.                 Else
    
56.                     k = k + 1
    
57.                 End If
    
58.             Else
    
59.                 For l = 1 To n1
    
60.                     jc(sj(j, l)) = jc(sj(j, l)) + 1
    
61.                 Next
    
62.             
    
63.                 Call dgZH2(s & " " & sj2(j), j, t + 1)
    
64.                
    
65.                 For l = 1 To n1
    
66.                     jc(sj(j, l)) = jc(sj(j, l)) - 1
    
67.                 Next
    
68.             End If
    
69.         End If
    
70.     Next
    
71. End Sub
    

复制代码

六码组合kagawa.rar (19.24 KB, 下载次数: 23)

2014-2-15 19:17 上传

点击文件名下载附件

跳转到最佳答案楼层

tgydslr

坐上沙发等着欣赏

mmc998

tgydslr 发表于 2014-2-14 20:26
坐上沙发等着欣赏

麻烦高手了

dsmch

1. Sub Macro1()
   
2. Dim arr, zf$, w(0 To 9)
   
3. Dim i%, i1%, i2%, i3%, i4%, i5%, i6%, s&
   
4. t = Timer
   
5. arr = Range("a2").CurrentRegion
   
6. zf = Space(23)
   
7. For i1 = 1 To UBound(arr) - 5
   
8.     Mid$(zf, 1, 3) = arr(i1, 1)
   
9.     For i2 = i1 + 1 To UBound(arr) - 4
   
10.         Mid$(zf, 5, 3) = arr(i2, 1)
    
11.         For i3 = i2 + 1 To UBound(arr) - 3
    
12.             Mid$(zf, 9, 3) = arr(i3, 1)
    
13.                 For i4 = i3 + 1 To UBound(arr) - 2
    
14.                     Mid$(zf, 13, 3) = arr(i4, 1)
    
15.                     For i5 = i4 + 1 To UBound(arr) - 1
    
16.                         Mid$(zf, 17, 3) = arr(i5, 1)
    
17.                         For i6 = i5 + 1 To UBound(arr)
    
18.                             Mid$(zf, 21, 3) = arr(i6, 1)
    
19.                             p = Replace(zf, " ", "")
    
20.                             GoSub line1
    
21.                             If Join(w, "") = String(9, "2") Then s = s + 1: Cells(s, 3) = zf
    
22.                             If s = 6 Then MsgBox Timer - t: Exit Sub
    
23.                             Erase w
    
24. Next i6, i5, i4, i3, i2, i1
    
25. Exit Sub
    
26. line1:
    
27. For i = 1 To Len(p)
    
28.     x = Val(Mid$(p, i, 1))
    
29.     w(x) = w(x) + 1
    
30. Next
    
31. Return
    
32. End Sub
    

复制代码

代码运行速度很慢，要几分钟，请高手优化
6组结果：
012 013 234 456 578 678
012 013 234 456 579 679
012 013 234 456 589 689
012 013 234 457 568 678
012 013 234 457 569 679
012 013 234 457 589 789

dsmch

……………………

香川群子

楼主的题目是：
从0-9这10个数中任取9个数的全部组合，
然后这9个数乘以2=18个数（保证每个数出现2次），
最后把这18个数分成6个不同的组合（每个组合中数字只出现1次）。


呵呵，根据这个设计算法，可能速度会快很多。

香川群子

只要先计算1-9的全部结果，
然后把1-9分别置换为0就可以得到全部6码组合结果。

香川群子

这个应该用递归做比较简单吧。用空研究一下。

香川群子

1. 
   
2. Dim sj&(), sj2$(), jc&(), jg$(), c&, m1&, n1&, m2&, n2&, k&, cnt&, tms#, cnt2&
   
3. Sub kagawa()
   
4.     tms = Timer
   
5.     [a1].CurrentRegion.Offset(1) = ""
   
6.    
   
7.     m1 = 9: n1 = 3
   
8.     k = Application.Combin(m1, n1) 'k=84
   
9.     ReDim sj&(1 To k, 1 To n1)  'Get Combin(9,3)
   
10.     ReDim sj2$(1 To k) 'Get Combin(9,3)
    
11.     k = 0: Call dgZH1("", 0, 1)
    
12.    
    
13.     ReDim jc&(1 To m1)
    
14.    
    
15.     m2 = k: n2 = 6: c = 2
    
16.     k = Application.Combin(m2, n2) 'k=406,481,544
    
17.     cnt = 10 ^ 4: ReDim jg$(1 To cnt, 1 To 1)
    
18.     k = 1: Call dgZH2("", 0, 1) 'k=122,220
    
19.    
    
20.     Cells(Cells.Rows.Count, 1).End(3).Offset(1).Resize(k - 1) = jg
    
21.     MsgBox Format(Timer - tms, "0.000s ") & Format([a1].End(4).Row - 1, "#,##0")
    
22.    
    
23. End Sub
    
24. Sub dgZH1(s$, i&, t&)
    
25.     Dim j&, l&
    
26.     For j = i + 1 To m1 - n1 + t
    
27.         If t = n1 Then
    
28.             k = k + 1
    
29.             For l = 1 To n1 - 1
    
30.                 sj(k, l) = Mid(s, l, 1)
    
31.             Next
    
32.             sj(k, n1) = j
    
33.             sj2(k) = s & j
    
34.         Else
    
35.             Call dgZH1(s & j, j, t + 1)
    
36.         End If
    
37.     Next
    
38. End Sub
    
39. Sub dgZH2(s$, i&, t&)
    
40.     Dim j&, l&
    
41. '    cnt2 = cnt2 + 1 '1,474,590
    
42.    
    
43.     For j = i + 1 To m2 - n2 + t
    
44.         For l = 1 To n1
    
45.             If jc(sj(j, l)) = c Then Exit For
    
46.         Next
    
47.         
    
48.         If l = n1 + 1 Then
    
49.             If t = n2 Then
    
50.                 jg(k, 1) = Mid(s, 2) & " " & sj2(j)
    
51.                 If k = cnt Then
    
52.                     Cells(Cells.Rows.Count, 1).End(3).Offset(1).Resize(cnt) = jg
    
53.                     Application.StatusBar = Format([a1].End(4).Row - 1, "#,##0") & Format(Timer - tms, " 0.000s ") & s & sj2(j)
    
54.                     k = 1
    
55.                 Else
    
56.                     k = k + 1
    
57.                 End If
    
58.             Else
    
59.                 For l = 1 To n1
    
60.                     jc(sj(j, l)) = jc(sj(j, l)) + 1
    
61.                 Next
    
62.             
    
63.                 Call dgZH2(s & " " & sj2(j), j, t + 1)
    
64.                
    
65.                 For l = 1 To n1
    
66.                     jc(sj(j, l)) = jc(sj(j, l)) - 1
    
67.                 Next
    
68.             End If
    
69.         End If
    
70.     Next
    
71. End Sub
    

复制代码

六码组合kagawa.rar (19.24 KB, 下载次数: 23)

2014-2-15 19:17 上传

点击文件名下载附件

香川群子

dsmch 发表于 2014-2-15 06:48
代码运行速度很慢，要几分钟，请高手优化
6组结果：
012 013 234 456 578 678

你这个代码在组合上没有问题，但检查效率太低……直接就是死机的节奏啊！