[已解决]求助/数据的组合

byeyes

                             

                           求助/数据的组合

                          
                                     数据.zip (13.04 KB, 下载次数: 43)

2012-8-17 11:38 上传

点击文件名下载附件
                             

最佳答案

月排行榜 / 总排行榜

happym8888

2012-8-18 00:36

组合的递归算法.rar (196.2 KB, 下载次数: 40)

2012-8-18 04:11 上传

点击文件名下载附件

1. Private Sub 清除_Click()
   
2. Range("K9:Q65536").Clear
   
3. End Sub
   
4. 
   
5. Private Sub 执行组合_Click()
   
6. Dim n As Long, Arr()
   
7.     br = Split(Cells(8, 2), ",")
   
8.     cr = Split(Cells(8, 3), ",")
   
9.     dr = Split(Cells(8, 4), ",")
   
10.     er = Split(Cells(8, 5), ",")
    
11.     fr = Split(Cells(8, 6), ",")
    
12.     gr = Split(Cells(8, 7), ",")
    
13.     hr = Split(Cells(8, 8), ",")
    
14.     ir = Split(Cells(8, 9), ",")
    
15. For col = 11 To 17
    
16.      n = Cells(8, col) - 1
    
17. For b = 0 To UBound(br)
    
18. For c = 0 To UBound(cr)
    
19. For d = 0 To UBound(dr)
    
20. For e = 0 To UBound(er)
    
21. For f = 0 To UBound(fr)
    
22. For g = 0 To UBound(gr)
    
23. For h = 0 To UBound(hr)
    
24. Arr = Array(br(b), cr(c), dr(d), er(e), fr(f), gr(g), hr(h))
    
25.   For i = 0 To UBound(ir)
    
26.     LQ = ir(i)
    
27.     Call 递归("", Arr, 0, 0, n, LQ, col)
    
28.     Next i, h,g, f, e, d, c, b, col
    
29. End Sub
    
30. 
    
31. Sub 递归(a, Arr, x As Long, y As Long, z As Long, LQ, c)
    
32.     If y = z Then
    
33.         Cells(65536, c).End(xlUp).Offset(1) = Right(a, Len(a) - 1) & "," & LQ
    
34.         Exit Sub
    
35.     End If
    
36.     If x = UBound(Arr) + 1 Then Exit Sub
    
37.     If y + UBound(Arr) - x + 1 < z Then Exit Sub
    
38.     Call 递归(a & "," & Arr(x), Arr, x + 1, y + 1, z, LQ, c)
    
39.     Call 递归(a, Arr, x + 1, y, z, LQ, c)
    
40. End Sub
    

复制代码

跳转到最佳答案楼层

zjcat35

应该是彩票问题吧！！！！

byeyes

               是想组合文字，用数字代替文字方便老师们看，请帮帮忙

上清宫主

不难，就是规则没全明白

jxncfxsf

Sub 组合()
Dim m, n As Long
Dim str As String
Dim ar, arr, arrr()
str = Cells(8, 2).Text & "," & Cells(8, 3).Text & "," & Cells(8, 4).Text & "," & Cells(8, 5).Text & "," & Cells(8, 6).Text & "," & Cells(8, 7).Text & "," & Cells(8, 8).Text
ar = Split(str, ",")
arr = Split(Cells(8, 9).Text, ",")
ReDim arrr(1 To (UBound(ar) + 1) * (UBound(arr) + 1), 1 To 1)

For n = 1 To UBound(ar) + 1
For m = 1 To UBound(arr) + 1
arrr(m * n, 1) = ar(n - 1) & "，" & arr(m - 1)
Next m
Next n
Range("K10").Resize(UBound(arrr)) = arrr
End Sub
Sub 清除()
Range("k10:q65536").Clear
End Sub

happym8888

这个题目可不简单

byeyes

               难怪5楼的   jxncfxsf  只帮我生成组合2 ，你能帮帮忙

上清宫主

没说明，看不懂组合3、4……是什么规则

byeyes

上清宫主 发表于 2012-8-17 22:37
没说明，看不懂组合3、4……是什么规则

  喔，你好，原来规则没说清楚：组合3就是前面7个单元格组合成组合2后再和最后面的单元格组合成组合3
                                                   组合4就是前面7个单元格组合成组合3后再和最后面的单元格组合成组合4
                                                   组合5就是前面7个单元格组合成组合4后再和最后面的单元格组合成组合5
                                                   组合6就是前面7个单元格组合成组合5后再和最后面的单元格组合成组合6
                                                   组合7就是前面7个单元格组合成组合6后再和最后面的单元格组合成组合7
                                                   组合8就是前面7个单元格组合成组合7后再和最后面的单元格组合成组合8


                        

happym8888

组合的递归算法.rar (196.2 KB, 下载次数: 40)

2012-8-18 04:11 上传

点击文件名下载附件

1. Private Sub 清除_Click()
   
2. Range("K9:Q65536").Clear
   
3. End Sub
   
4. 
   
5. Private Sub 执行组合_Click()
   
6. Dim n As Long, Arr()
   
7.     br = Split(Cells(8, 2), ",")
   
8.     cr = Split(Cells(8, 3), ",")
   
9.     dr = Split(Cells(8, 4), ",")
   
10.     er = Split(Cells(8, 5), ",")
    
11.     fr = Split(Cells(8, 6), ",")
    
12.     gr = Split(Cells(8, 7), ",")
    
13.     hr = Split(Cells(8, 8), ",")
    
14.     ir = Split(Cells(8, 9), ",")
    
15. For col = 11 To 17
    
16.      n = Cells(8, col) - 1
    
17. For b = 0 To UBound(br)
    
18. For c = 0 To UBound(cr)
    
19. For d = 0 To UBound(dr)
    
20. For e = 0 To UBound(er)
    
21. For f = 0 To UBound(fr)
    
22. For g = 0 To UBound(gr)
    
23. For h = 0 To UBound(hr)
    
24. Arr = Array(br(b), cr(c), dr(d), er(e), fr(f), gr(g), hr(h))
    
25.   For i = 0 To UBound(ir)
    
26.     LQ = ir(i)
    
27.     Call 递归("", Arr, 0, 0, n, LQ, col)
    
28.     Next i, h,g, f, e, d, c, b, col
    
29. End Sub
    
30. 
    
31. Sub 递归(a, Arr, x As Long, y As Long, z As Long, LQ, c)
    
32.     If y = z Then
    
33.         Cells(65536, c).End(xlUp).Offset(1) = Right(a, Len(a) - 1) & "," & LQ
    
34.         Exit Sub
    
35.     End If
    
36.     If x = UBound(Arr) + 1 Then Exit Sub
    
37.     If y + UBound(Arr) - x + 1 < z Then Exit Sub
    
38.     Call 递归(a & "," & Arr(x), Arr, x + 1, y + 1, z, LQ, c)
    
39.     Call 递归(a, Arr, x + 1, y, z, LQ, c)
    
40. End Sub
    

复制代码