ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 2228|回复: 6

[分享] 使用字典进行随机排序

[复制链接]

TA的精华主题

TA的得分主题

发表于 2017-5-9 10:29 | 显示全部楼层 |阅读模式
本帖最后由 liulang0808 于 2017-5-9 15:52 编辑

最近有几个人问随机排序的事情
做了一段代码,供大家讨论


Sub 右箭头1_Click()
    arr = [a1:c8]
    Set d = CreateObject("scripting.dictionary")
    For Each a In arr
        d(a) = ""
    Next
    Randomize
    For j = 1 To UBound(arr)
        For i = 1 To UBound(arr, 2)
            a = Int(Rnd * 999 * d.Count) Mod d.Count
            arr(j, i) = d.keys()(a)
            d.Remove d.keys()(a)
        Next i
    Next j
    [f1:h8] = arr
End Sub

感谢 笑着...两年过去 ,提示使用RandBetween,精简了代码
Sub 右箭头2_Click()
    arr = [a1:c8]
    Set d = CreateObject("scripting.dictionary")
    For Each a In arr
        d(a) = ""
    Next
    For j = 1 To UBound(arr)
        For i = 1 To UBound(arr, 2)
            a = Application.RandBetween(0, d.Count - 1)
            arr(j, i) = d.keys()(a)
            d.Remove d.keys()(a)
        Next i
    Next j
    [f1:h8] = arr
End Sub



目前是数据区域内容不重复,直接使用以上代码
如果数据有重复,就不用数组,直接去表格地址作为字典的key值即可

QQ截图20170509142913.jpg

随机排序.zip

16.05 KB, 下载次数: 51

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-5-9 11:06 | 显示全部楼层
我还是比较喜欢用RandBetween
  1. a=Application.RandBetween(1, d.Count - 1)
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-5-9 15:24 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
笑着...两年过去 发表于 2017-5-9 11:06
我还是比较喜欢用RandBetween

这个在表格函数的时候用过的
vba里基本不用的,都是rnd

谢谢指点,这样能缩减不少代码行数的

TA的精华主题

TA的得分主题

发表于 2017-5-9 15:29 | 显示全部楼层
liulang0808 发表于 2017-5-9 15:24
这个在表格函数的时候用过的
vba里基本不用的,都是rnd

指点不敢,
咱们交流交流、共同学习

TA的精华主题

TA的得分主题

发表于 2017-5-9 16:05 | 显示全部楼层
关于随机排序,我前段时间也有兴趣研究了一下,思考了3个不同方式。都是以1列数据进行的实验,多列其实也差不多,转换成1维数组就可以用了。

下面是三种思路的实验结果。
1) 循环生成随机数n,用arr(n)创建字典,当数组所有的数都被随机到时,d.Count =UBound(arr),循环结束。这种方法,大概需要随机数组大小的10倍次数,可以把所有的数随机到。

代码如下:
  1. Sub test1()
  2.     Dim arr, u&, t
  3.     t = Timer
  4.     arr = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
  5.     u = UBound(arr)
  6.     Set d = CreateObject("Scripting.Dictionary")
  7.     Do Until d.Count = u
  8.         d(arr(Int(Rnd() * u + 1), 1)) = ""
  9.     Loop
  10.     Range("C1").Resize(u, 1) = Application.Transpose(d.keys)
  11.     Set d = Nothing
  12.     Debug.Print Timer - t
  13. End Sub
复制代码

代码试验结果:
10000个数据排序用时约0.25-0.3s
50000个数据排序用时约1.3-1.8s 循环次数 45W-60W

2) 循环生成随机数n,将arr(n)赋值给brr(i),然后将arr(n)="",当下一次随机到arr(n)已被取过数(即arr(n)=“”)时,则在arr内上下逐个找到不为空的值。该方法生成随机数的次数为UBound(arr),但因为有时候碰到arr数被取过时需要上下查找,所以会增加很多次另外的循环。

代码为:
  1. Sub test()
  2.     Dim arr, brr(), i&, j&, n&, u&, k&
  3.     arr = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
  4.     u = UBound(arr)
  5.     ReDim brr(1 To u)
  6.     For i = u To 1 Step -1
  7.         n = Int(u * Rnd + 1)
  8.         If arr(n, 1) <> "" Then
  9.             brr(i) = arr(n, 1): arr(n, 1) = ""
  10.         Else
  11.             For j = 1 To Application.Max(n - 1, u - n)
  12.                 If n - j >= 1 Then
  13.                     If arr(n - j, 1) <> "" Then
  14.                         brr(i) = arr(n - j, 1)
  15.                         arr(n - j, 1) = ""
  16.                         Exit For
  17.                     End If
  18.                 End If
  19.                 If n + j <= u Then
  20.                     If arr(n + j, 1) <> "" Then
  21.                         brr(i) = arr(n + j, 1): arr(n + j, 1) = ""
  22.                         Exit For
  23.                     End If
  24.                 End If
  25.             Next j
  26.             
  27.         End If
  28.     Next
  29.     Range("C1").Resize(u) = Application.Transpose(brr)
  30. End Sub
复制代码

代码试验结果:
10000个数据排序用时约0.15-0.3 s
50000个数据排序用时约1.2-2.2s 循环次数 25W-50W

3) 这个方法思路比较简单,就是随机UBound(arr)生成随机数,且随机数的最大值逐步减少至1,每次得到随机数n时将arr(n)赋值给brr(i),并将arr(n)后的数全部前移一格。

这种方法的循环次数是固定的,可以算出来。假设10个数的一维数组,需要移动9×8×7...×1次,如果10000次,则需要循环(10000+1)*5000=50005000

该方法写起来最简单,已最好理解,数少的时候,可能没问题,但数一多,代码运行起来就比较慢了。我试验的时候,10000个数据排序用时约2.5s。
  1. Sub test3()
  2.     Dim arr, brr(), i&, j&, n&, u&
  3.     arr = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
  4.     u = UBound(arr)
  5.     ReDim brr(1 To u)
  6.     For i = u To 1 Step -1
  7.         n = Int(i * Rnd + 1)
  8.         brr(i) = arr(n, 1) ': arr(n, 1) = ""
  9.         For j = n To i
  10.             If j = u Then Exit For
  11.             arr(j, 1) = arr(j + 1, 1) ': arr(j + 1, 1) = ""
  12.         Next j
  13.     Next
  14.     Range("C1").Resize(u) = Application.Transpose(brr)
  15. End Sub
复制代码


TA的精华主题

TA的得分主题

发表于 2018-11-26 09:17 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
学习!!!!!!!!!!!!!!!!!

TA的精华主题

TA的得分主题

发表于 2018-11-26 09:20 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
为楼上的大侠们点赞。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 10:07 , Processed in 0.051586 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表