求高手指教：如何用VBA在EXCEL中生成双色球红球33选6的所有组合明细

ywcxnet

求高手指教：如何用VBA在EXCEL中生成双色球红球33选6的所有组合明细

香川群子

33选6，组合结果共=1,107,568

在2003中可以排满接近17列……

这么多组合明细，给了你也没有毛的用处。


如果需要生成组合的代码，
最简单最有效的是：

1. Sub Combin_33_6()
   
2.     Dim a%, b%, c%, d%, e%, f%, s$
   
3.     For a = 1 To 33 - 5
   
4.     For b = a + 1 To 33 - 4
   
5.     For c = b + 1 To 33 - 3
   
6.     For d = c + 1 To 33 - 2
   
7.     For e = d + 1 To 33 - 1
   
8.     For f = e + 1 To 33
   
9.         s = a & ";" & b & ";" & c & ";" & d & ";" & e & ";" & f
   
10.     Next f, e, d, c, b, a
    
11.    
    
12. End Sub

复制代码

hlly888

http://club.excelhome.net/thread-819199-1-7.html

ywcxnet

高手 按照你的启发：我编写了以下代码：
   Sub combin_33_6()
   Dim a, b, c, d, e, f As Integer
   Dim thecell As Range
   Sheets("sheet1").Select
    Set thecell = Range("a1")
       For a = 1 To 28                                                'a最小为1
      
           For b = a + 1 To 29                                        'b最小为2
                             If a = b Then b = b + 1
               For c = b + 1 To 30                                    'c最小为3
                             If b = c Then c = c + 1
                   For d = c + 1 To 31                                'd最小为4
                             If c = d Then d = d + 1
                      For e = d + 1 To 32                             'e最小为5
                     
                             If d = e Then e = e + 1
                         For f = e + 1 To 33                          'f最小为6
                             If e = f Then f = f + 1
                             thecell.Value = a
                             Set thecell = thecell.Offset(0, 1)    '  移位
                             thecell.Value = b
                             Set thecell = thecell.Offset(0, 1)
                             thecell.Value = c
                             Set thecell = thecell.Offset(0, 1)
                             thecell.Value = d
                             Set thecell = thecell.Offset(0, 1)
                             thecell.Value = e
                             Set thecell = thecell.Offset(0, 1)
                             thecell.Value = f
                             Set thecell = thecell.Offset(1, -5)  ' 重新定位，换行换列
                         Next f
                      Next e
                   Next d
                Next c
            Next b
        Next a
   
End Sub
      在向工作表中写入第1048576条记录后，无法再写入组合记录，我按照第1048576记录的组合值继续向第二张工作表追加，运行代码如下
  Sub combin_33_6_1()
   Dim a, b, c, d, e, f As Integer
   Dim thecell As Range
   Sheets("sheet2").Select
    Set thecell = Range("a1")
       For a = 12 To 28                                                'a最小为1
      
           For b = 17 To 29                                        'b最小为2
                             If a = b Then b = b + 1
               For c = 22 To 30                                    'c最小为3
                             If b = c Then c = c + 1
                   For d = 27 To 31                               'd最小为4
                             If c = d Then d = d + 1
                      For e = 28 To 32                             'e最小为5
                     
                             If d = e Then e = e + 1
                         For f = 33 To 33                          'f最小为6
                             If e = f Then f = f + 1
                             thecell.Value = a
                             Set thecell = thecell.Offset(0, 1)    '  移位
                             thecell.Value = b
                             Set thecell = thecell.Offset(0, 1)
                             thecell.Value = c
                             Set thecell = thecell.Offset(0, 1)
                             thecell.Value = d
                             Set thecell = thecell.Offset(0, 1)
                             thecell.Value = e
                             Set thecell = thecell.Offset(0, 1)
                             thecell.Value = f
                             Set thecell = thecell.Offset(1, -5)  ' 重新定位，换行换列
                         Next f
                      Next e
                   Next d
                Next c
            Next b
        Next a
   
End Sub

在第2张工作表中只有33450条记录，两个表加起来1082029条记录，与combin（33，6）=1107568 相差 25539 条 记录，请高手指教，如何找出错误。多谢高手！

香川群子

很简单，虽然第 1048576 个组合结果是：12，17，22，27，28，33 没错，

但在这以后的循环中，当a升到13时，b还是要从14开始……

然而，你的代码直接就规定b从17开始，那么
a=13，b=14,……
a=13，b=15,……
a=13，b=16,……

这些组合，就全部被你跳过去了。

香川群子

比如，序号1053305，即第2张表的第4729个组合，应该是：13，14，15，16，17，18

你去查一下，你的结果里有没有？ 我想肯定是没有。呵呵。

香川群子

顺便说，你的代码改了以后，很愚蠢。

类似于 If a = b Then b = b + 1

这样的判断是不需要的，因为更本不可能发生。

香川群子

组合结果合并成一列，含输出结果的代码：

1. Sub Combin_33_6()
   
2.     Dim a%, b%, c%, d%, e%, f%, k&, l%, m&, s$
   
3. '    m = 4 ^ 8 '2003版
   
4.     m = 4 ^ 10 '2007版
   
5.     ReDim r(1 To m, 1 To 1) '2003或2007版
   
6.    
   
7.     For a = 1 To 33 - 5
   
8.     For b = a + 1 To 33 - 4
   
9.     For c = b + 1 To 33 - 3
   
10.     For d = c + 1 To 33 - 2
    
11.     For e = d + 1 To 33 - 1
    
12.     For f = e + 1 To 33
    
13.         k = k + 1
    
14.         If k > m Then
    
15.             Cells(1, l * 2 + 1).Resize(m) = r
    
16.             ReDim r(1 To m, 1 To 1) '2003或2007版
    
17.             l = l + 1
    
18.             k = 1
    
19.         End If
    
20.         r(k, 1) = a & ";" & b & ";" & c & ";" & d & ";" & e & ";" & f
    
21.    
    
22.     Next f, e, d, c, b, a
    
23.     Cells(1, l * 2 + 1).Resize(k) = r
    
24. End Sub

复制代码

香川群子

组合结果分成6列输出的代码：

1. Sub Combin_33_6_6()
   
2.     Dim a%, b%, c%, d%, e%, f%, k&, l%, m&, s$
   
3. '    m = 4 ^ 8 '2003版
   
4.     m = 4 ^ 10 '2007版
   
5.     ReDim r(1 To m, 1 To 6) '2003或2007版
   
6.    
   
7.     For a = 1 To 33 - 5
   
8.     For b = a + 1 To 33 - 4
   
9.     For c = b + 1 To 33 - 3
   
10.     For d = c + 1 To 33 - 2
    
11.     For e = d + 1 To 33 - 1
    
12.     For f = e + 1 To 33
    
13.         k = k + 1
    
14.         If k > m Then
    
15.             Cells(1, l * 7 + 1).Resize(m, 6) = r
    
16.             ReDim r(1 To m, 1 To 1) '2003或2007版
    
17.             l = l + 1
    
18.             k = 1
    
19.         End If
    
20.         r(k, 1) = a
    
21.         r(k, 2) = b
    
22.         r(k, 3) = c
    
23.         r(k, 4) = d
    
24.         r(k, 5) = e
    
25.         r(k, 6) = f
    
26.    
    
27.     Next f, e, d, c, b, a
    
28.     Cells(1, l * 7 + 1).Resize(k, 6) = r
    
29. End Sub

复制代码

ywcxnet

香川群子 发表于 2012-2-13 00:28
顺便说，你的代码改了以后，很愚蠢。

类似于 If a = b Then b = b + 1

尊敬的高手：经过你的指点，我知道错误在第二长表的初始赋值上，经过思考我认为程序是不是能够这样写？，当接近1048576行时将输出结果输出到第二张表上，
故在程序开始设置一个行计数变量，但是程序运行好像进入死循环，不知道错在哪里，顺便告诉高手那句  If a = b Then b = b + 1 好像有必要，我就是看见生成的
数据中有  1,2,3,4,6,6  才写的，我的程序如下，烦高手赐教：
Sub combin_33_6()
   Dim a, b, c, d, e, f As Integer
   Dim thecell As Range
   Dim i As Long
   i = 0
   Sheets("sheet1").Select
    Set thecell = Range("a1")
       For a = 1 To 28                                                'a最小为1
      
           For b = a + 1 To 29                                        'b最小为2
                             If a = b Then b = b + 1
               For c = b + 1 To 30                                    'c最小为3
                             If b = c Then c = c + 1
                   For d = c + 1 To 31                                'd最小为4
                             If c = d Then d = d + 1
                      For e = d + 1 To 32                             'e最小为5
                     
                             If d = e Then e = e + 1
                         For f = e + 1 To 33                          'f最小为6
                             If e = f Then f = f + 1
                             i = i + 1
                             
                             If i < 1048575 Then
                             
                                     thecell.Value = a
                                     Set thecell = thecell.Offset(0, 1)    '  移位
                                     thecell.Value = b
                                     Set thecell = thecell.Offset(0, 1)
                                     thecell.Value = c
                                     Set thecell = thecell.Offset(0, 1)
                                     thecell.Value = d
                                     Set thecell = thecell.Offset(0, 1)
                                     thecell.Value = e
                                     Set thecell = thecell.Offset(0, 1)
                                     thecell.Value = f
                                      Set thecell = thecell.Offset(1, -5)  ' 重新定位，换行换列
                             Else
                                      Sheets("sheet2").Select
                                      Set thecell = Range("a1")
                                     thecell.Value = a
                                     Set thecell = thecell.Offset(0, 1)    '  移位
                                     thecell.Value = b
                                     Set thecell = thecell.Offset(0, 1)
                                     thecell.Value = c
                                     Set thecell = thecell.Offset(0, 1)
                                     thecell.Value = d
                                     Set thecell = thecell.Offset(0, 1)
                                     thecell.Value = e
                                     Set thecell = thecell.Offset(0, 1)
                                     thecell.Value = f
                                     Set thecell = thecell.Offset(1, -5)  ' 重新定位，换行换列
                             
                             End If
                             
                         Next f
                      Next e
                   Next d
                Next c
            Next b
        Next a
   
End Sub

不知道什么原因，程序运行很久，无法结束？