生成不重复随机数的一段代码

toopoor · 发表于 2011-1-22 21:04

经常看到有朋友需要生成不重复的随机数，经过一晚上奋战，终于搞出来了，分享一下，请大家斧正。
更改d1到d3单元格可以修改相关参数

Sub CreateRND()
Dim arr() As Integer                         '定义数组
ReDim arr(range("d3").Value)                '更改数组大小
Dim min As Integer                         '定义随机数的最小值
Dim max As Integer                         '定义随机数的最大值
Dim flag As Boolean                         '定义标志变量，用来判断是否有重复值
max = range("d2").Value                      '将d2单元格的数值赋值给最大值
min = range("d1").Value                      '将d1单元格的数值赋值给最小值

If (max - min + 1 < range("d3").Value) Then '如果最大值和最小值的差小于d3单元格的数值就什么也不做
Exit Sub
End If
Randomize (Now())                            '用当前时间生成随机数种子

For i = 0 To range("d3").Value             '循环生成随机数
Do
      arr(i) = Rnd() * (max - min) + min '生成随机数
      flag = False
      For j = 0 To (i - 1)                '循环判断当前的随机数是否和前面生成的随机数相同，如果相同就重新生成
         If (arr(i) = arr(j)) Then
         flag = True
         End If

      Next
Loop While flag
Next
Columns("A:A").ClearContents
range("a1").Resize(range("d3").Value) = Application.Transpose(arr)    '输出结果

End Sub

[ 本帖最后由 toopoor 于 2011-1-22 21:05 编辑 ]

xkx590 · 发表于 2011-1-22 21:09

谢谢，收藏了。

lsftest · 发表于 2011-1-22 22:10

不好，效率太低，而且，看到“定义标志变量，用来判断是否有重复值”、“循环判断当前的随机数是否和前面生成的随机数相同，如果相同就重新生成”就大概可知道，这算法大多数在理论上有可能1000年都跳不出完整结果。。
以前在搞VB的时候，看过一种叫“跳蚤算法”及其变形算法，是专门用来解决这类问题的，原理也很简单，找来看看吧。。
但我估计，具体到excel这个领域，解决此类问题有更简单的途径。。

灰袍法师 · 发表于 2011-1-22 23:00

楼主的代码排版很漂亮

注意：目前最完美解决方法在27楼和29楼

可以生成 2百万亿范围内的数千万个不重复随机整数

[ 本帖最后由灰袍法师于 2011-1-26 22:26 编辑 ]

lsftest · 发表于 2011-1-22 23:48

原帖由 灰袍法师 于 2011-1-22 23:00 发表
楼主的代码排版很漂亮

但是不应该用Integer类型，至少也应该用long

而且速度上确实如楼上所言，循环数组去判断重复，效率低得无法接受，建议学习一下字典的用法

其实我认为，VBA根本不需要去管重复与否，直 ...

我上面说的“理论上有可能1000年都跳不出完整结果。。”也包括你所说的这种思路。。。极端点可以这么说：
“需要 10000 - 1000000 随机整数10万个”，如果只直接生成1000000个范围内的随机整数，那么“理论”上说，你生成的这1000000个数有可能都等于10008，那么去掉重复，其实就只生成了一个数。。
这例子有点极端，但在实际应用中，如果生成1000000个范围内的数，但最后去掉重复数后，只剩下99999个数，这种概率是不是大增了？？如果这样又该怎么办？

我觉得还是采用逻辑严谨一点的方法吧。

[ 本帖最后由 lsftest 于 2011-1-22 23:52 编辑 ]

灰袍法师 · 发表于 2011-1-23 02:53

原帖由 lsftest 于 2011-1-22 23:48 发表

如果生成1000000个范围内的数，但最后去掉重复数后，只剩下99999个数，这种概率是不是大增了？？如果这样又该怎么办？

这个概率其实非常小，比电脑下一秒钟就烧掉的几率还小。

不过，楼主的做法其实更好，因为我刚发现Excel2007的去掉重复值功能，实在太慢了，比自己写代码用VBA字典去处理还要慢得多

所以附件还是不断检查当前的随机整数是否已经生成，只不过换成VBA字典检查。

生成十万个数字以内，不管范围多少(即使是1-10万都可以)，绝对都是1分钟内完成。

当然，要生成100万个范围是1-100万的话，就不行了，直接把100万个数随机排序才是正解。

21楼有更完美的附件。27楼有更完美的附件，29楼有最完美的附件

[ 本帖最后由灰袍法师于 2011-1-26 22:22 编辑 ]

toopoor · 发表于 2011-1-23 09:22

受灰袍法师启发，改用字典来判断是否有重复值，速度快了很多。

Sub CreateRND()
Dim arr() As Long                                  '定义数组
ReDim arr(range("d3").Value)                      '更改数组大小
Dim min As Long                                  '定义随机数的最小值
Dim max As Long                                  '定义随机数的最大值
Dim flag As Boolean                               '定义标志变量，用来判断是否有重复值
Dim dict                                           '字典变量
Dim key As Long                                  '字典值
Dim count As Long
Dim t0
t0 = Timer

count = [d3].Value
max = range("d2").Value                            '将d2单元格的数值赋值给最大值
min = range("d1").Value                            '将d1单元格的数值赋值给最小值
Set dict = CreateObject("Scripting.Dictionary")
If (max - min + 1 < range("d3").Value) Then       '如果最大值和最小值的差小于d3单元格的数值就什么也不做
Exit Sub
End If
Randomize (Now())                                  '用当前时间生成随机数种子

For i = 0 To count - 1                            '循环生成随机数
Do
      key = Rnd() * (max - min) + min          '生成随机数
      flag = False
      If (dict.exists(key)) Then             '循环判断当前的随机数是否和前面生成的随机数相同，如果相同就重新生成
         flag = True
      Else
         arr(i) = key
         dict.Add key, ""
      End If
Loop While flag
Next
[a:a].Clear
range("a1").Resize(count) = Application.Transpose(arr)    '输出结果
[d4] = Timer - t0

End Sub

[ 本帖最后由 toopoor 于 2011-1-23 09:31 编辑 ]

toopoor · 发表于 2011-1-23 10:29

'Dim arr() As Long                                  '定义数组
'ReDim arr(range("d3").Value)                      '更改数组大小
Dim min As Long                                  '定义随机数的最小值
Dim max As Long                                  '定义随机数的最大值
Dim flag As Boolean                               '定义标志变量，用来判断是否有重复值
Dim dict                                           '字典变量
Dim key As Long                                  '字典值
Dim count As Long
Dim t0
t0 = Timer

count = [d3].Value
max = range("d2").Value                            '将d2单元格的数值赋值给最大值
min = range("d1").Value                            '将d1单元格的数值赋值给最小值
Set dict = CreateObject("Scripting.Dictionary")
If (max - min + 1 < range("d3").Value) Then       '如果最大值和最小值的差小于d3单元格的数值就什么也不做
Exit Sub
End If
Randomize (Now())                                  '用当前时间生成随机数种子

For i = 0 To count - 1                            '循环生成随机数
Do
      key = Rnd() * (max - min) + min          '生成随机数
      flag = False
      If (dict.exists(key)) Then             '循环判断当前的随机数是否和前面生成的随机数相同，如果相同就重新生成
         flag = True
      Else
'          arr(i) = key
         dict.Add key, ""
      End If
Loop While flag
Next
[a:a].Clear
range("a1").Resize(count) = Application.Transpose(dict.keys) '输出结果
[d4] = Timer - t0

End Sub

lsftest · 发表于 2011-1-23 10:33

呵呵，翻翻谷歌，老黄历还在，有兴趣了解跳蚤算法的就看看回复吧，我在那贴子回复里贴的那“小仙妹”的确是个算法强人。。
http://topic.csdn.net/t/20060830/11/4985999.html

灰袍法师 · 发表于 2011-1-23 16:10

原帖由 lsftest 于 2011-1-23 10:33 发表
呵呵，翻翻谷歌，老黄历还在，有兴趣了解跳蚤算法的就看看回复吧，我在那贴子回复里贴的那“小仙妹”的确是个算法强人。。
http://topic.csdn.net/t/20060830/11/4985999.html

看完，这个跳蚤算法其实是一个简化的洗牌算法，而且你们在该链接也讨论过，对极大的数据范围无效

我也建议你看一下《计算机编程的艺术》第二部，伪随机数生成算法章节，洗牌算法。

洗牌算法可以避免要求数字极度接近数值范围引起的低效率生成问题

不过数据范围很大，如一亿，没法在内存保留所有数值以供交换，那么还是要靠抽样－去重复

另一方面，如果数据范围很大，而要求的数字很小，如100万选10

那么还是直接抽样－去重复快捷得多

所以这个生成m范围内n个不重复随机数的问题，其实要分3种情况来采用算法

1 m不大，或者n/m不超过0.5，那么直接抽样－去重复

2 m很大（超过50万），且n/m超过0.5，那么对m个数建随机堆，取前n个即可 O( m+n(logn) )，或者对m个数用洗牌算法O(n)

3 m非常大，内存无法保存所有m个数，那么也只能抽样－去重复了。。。。。。

另外建议楼主不要用Application.Transpose，超过65536个元素的数组就出错了。

[ 本帖最后由灰袍法师于 2011-1-23 16:31 编辑 ]

		自动登录	找回密码
密码			免费注册

[原创] 生成不重复随机数的一段代码

不用数组直接用字典速度可以更快一些