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

ywcxnet

尊敬的高手：经过你的指点，我知道错误在第二长表的初始赋值上，经过思考我认为程序是不是能够这样写？，当接近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

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

香川群子

什么样的程序才会出现数据中有  1,2,3,4,6,6 ？

我写的程序肯定不会的。


不管怎么说，
在 for b = a + 1 to 30 的循环中，
是据对不可能出现 b=a 的事件的。

因此，If a = b Then b = b + 1 是绝对不需要的。


如果你有运行结果会产生  1,2,3,4,6,6 结果的代码，
发个附件上来看看。

香川群子

11楼代码理论上不是死循环，因此，理论上最终能够运行直到结束。

但是，你写的这个极其愚蠢的代码，在一个一个单元格之间移动、写入数字，
导致Excel程序运行后死机，或假死机，是非常必然的后果。


我早就给你写过正确代码了。你不看不用，
大概是为了自己编写代码、学习吧，而且，你这个学习，不是模仿正确的代码，
而是非要自己想、自己写，等待错误发生……

这个，大概就是你的学习方法，对此，我除了给出极其愚蠢的评价，其它我也不好说什么了啊。呵呵。



最后说一点，11楼代码中有个错误bug：
If i < 1048575 Then
     ……这里OK
Else
    Sheets("sheet2").Select
    Set thecell = Range("a1")    ……下面OK
End IF

红字两行代码，只应该使用一次。
而你目前的效果，是i >= 1048575 的每一个i值，都会执行这两句代码。

致命的后果就是： 新的数据覆盖了前面的结果。最终所有结果都被覆盖，仅仅剩下最后一行的结果。

呵呵。

ywcxnet

香川群子 发表于 2012-2-14 10:23
什么样的程序才会出现数据中有  1,2,3,4,6,6 ？

我写的程序肯定不会的。

尊敬的高手：经过你的指点，我好像在一面镜子中看到了自己是多么的愚蠢，为了能够聪明一点，我还想向你请教你一个问题，如何
在以下数据中用vba自动形成统计各个数字出现的次数结果
15        17        18        20        23        27       
6        8        24        29        30        32       
1        2        5        16        28        30       
1        3        6        10        21        23       
2        5        12        17        22        25       
6        9        14        19        25        28       
                                               
统计结果：        1（2）        2（2）        3（1）        5（2）        6（3）        8（1）
        9（1）        10（1）        12（1）        14（1）        15（1）        16（1）
        17（2）        18（1）        19（1）        20（1）        21（1）        22（1）
        23（2）        24（1）        25（2）        27（1）        28（2）        29（1）
        30（2）        32（1）       

烦高手赐教                       

香川群子

1. Excel函数方法：
使用辅助列的数组公式。
如果不使用辅助列，将更加复杂。

2. VBA自定义函数方法：
对本题的特殊条件，可以简单高效地得到结果。
所谓特殊条件是：统计对象为自然数整数。(可以包含0和负数，但不含小数)
本题自定义函数设置为 0-99 范围。

1. Function tj(Rng As Range, Optional k = 0)
   
2.     Dim a(99)
   
3.     For i = 1 To Rng.Count
   
4.         a(Rng.Cells(i)) = a(Rng.Cells(i)) + 1
   
5.     Next
   
6.     For i = 0 To 99
   
7.         If a(i) > 0 Then
   
8.             c = c + 1
   
9.             If k = 0 Then
   
10.                 tj = tj & " " & i & "(" & a(i) & ")"
    
11.             Else
    
12.                 If c = k Then
    
13.                     tj = i & "(" & a(i) & ")"
    
14.                     Exit Function
    
15.                 End If
    
16.             End If
    
17.         End If
    
18.     Next
    
19.     tj = Mid(tj, 2)
    
20. End Function

复制代码

3. VBA代码执行方法-1：
如果采用同样的，面对自然数整数对象的方式，可以使用和上面VBA函数一样的算法思路，
差异仅仅在于获取数据和输出结果上。

1. Sub tj1()
   
2.     arr = [a1].CurrentRegion
   
3.     rw = UBound(arr)
   
4.     cl = UBound(arr, 2)
   
5.     Dim brr(99)
   
6.    
   
7.     For i = 1 To rw
   
8.         For j = 1 To cl
   
9.             brr(arr(i, j)) = brr(arr(i, j)) + 1
   
10.         Next
    
11.     Next
    
12.    
    
13.     k = 0
    
14.     ReDim crr(rw - 1, cl - 1)
    
15.     For i = 0 To 99
    
16.         If brr(i) > 0 Then
    
17.             crr(k \ cl, k Mod cl) = i & "(" & brr(i) & ")"
    
18.             k = k + 1
    
19.         End If
    
20.     Next
    
21.    
    
22.     [a27].Resize(k \ cl + 1, cl) = crr
    
23.    
    
24. End Sub

复制代码

4. VBA代码执行方法-2：
如果考虑统计对象为任意值(文本，含小数的数值等)，那么应该使用字典方法来统计。
但是，最后得到的结果，显然是乱序的。
如果在VBA内存数组中排序，代码复杂化不说，效率也是不太高的。
因此，直接采用输出数据后排序的方法了。

即使在工作表内排序以后再做结果的整理，也是不错的选择。

1. Sub tj2()
   
2.     arr = [a1].CurrentRegion
   
3.     rw = UBound(arr)
   
4.     cl = UBound(arr, 2)
   
5.     ReDim brr(1 To rw * cl, 1 To 2)
   
6.    
   
7.     Set d = CreateObject("Scripting.Dictionary")
   
8.     For i = 1 To rw
   
9.         For j = 1 To cl
   
10.             t = d(CStr(arr(i, j)))
    
11.             If t = "" Then
    
12.                 k = k + 1
    
13.                 d(CStr(arr(i, j))) = k
    
14.                 t = k
    
15.                 brr(k, 1) = arr(i, j)
    
16.             End If
    
17.             brr(t, 2) = brr(t, 2) + 1
    
18.         Next
    
19.     Next
    
20.    
    
21.     [l1].Resize(k, 2) = brr
    
22.     [l1].CurrentRegion.Sort key1:=[l1], Order1:=xlAscending, Header:=xlNo
    
23.    
    
24. End Sub
    

复制代码

这样，一共有4种例子。请看附件。

ywcxnet

尊敬的高手：因为我不是学计算机编程专业的，我是学财务会计专业的，所以计算机底子很差，你写的程序因为我很愚蠢，看不懂，我自己写了一个函数：想实现的功能是统计双色球前五期中奖号码出现的次数，并且将统计结果输出在一个单元格中，但是有很多细节有问题自己无法处理，烦请高手帮我修改一下程序，不胜感激。

ywcxnet

尊敬的高手：统计结果从中奖数据表的j7开始输出，程序应该怎样改，请高手帮忙。

ywcxnet

尊敬的高手：因为我不是学计算机编程专业的，我是学财务会计专业的，所以计算机底子很差，你写的程序因为我很愚蠢，看不懂，我自己写了一个函数：想实现的功能是统计双色球前五期中奖号码出现的次数，并且将统计结果输出在一个单元格中，统计结果从中奖数据表的j7开始输出，我写的函数he_5保存在中奖数据统计表中，该表在上传的附件中，请见附件，程序应该怎样改，请高手帮忙，不胜感激。

xsy我可以很好

香川群子高人

强烈期待你出一个e版彩票软件

中国亿万彩民一定会尊你为彩神

xsy我可以很好

ywcxnet 发表于 2012-2-26 23:00
尊敬的高手：因为我不是学计算机编程专业的，我是学财务会计专业的，所以计算机底子很差，你写的程序因为我 ...

不明白楼主的要求
不知道是不是这意思



中奖数据统计.rar (41.65 KB, 下载次数: 209)

2012-2-27 23:53 上传

点击文件名下载附件