白话Excel函数公式 Office易学宝微视频教程合集(Excel+Word+PPT)
笨办法学VBA(从入门到精通) 高效办公必会的Office实战技巧
财务总监的Excel私房课 网易云课堂-Excel数据透视表应用大全
Excel图表神技
123
返回列表 发新帖
楼主: hustnzj

11117班第一次班委会-随机分组

[复制链接]
发表于 2012-3-8 00:47:30 | 显示全部楼层
Mas_T_er 发表于 2012-3-8 00:09
这几天看论坛里随机数据分类的方法和你这个差不多。。。做出来也就是这个样子 ,,,VBA  一点头绪的没有 ...

时间比较紧,咱又是小白。。先做个方案备用。。有高人用VBA咱也拥护!呵呵
回复 支持 反对

使用道具 举报

发表于 2012-3-8 07:57:20 | 显示全部楼层
20080901lx 发表于 2012-3-7 11:47
我在名单中找到了,但不知分在哪一组?

哦,谢谢你。
回复 支持 反对

使用道具 举报

发表于 2012-3-8 08:27:01 | 显示全部楼层
还没分好啊。。= =
回复 支持 反对

使用道具 举报

发表于 2012-3-8 11:06:53 | 显示全部楼层
本帖最后由 wmhlwx 于 2012-3-8 15:31 编辑

那我写个VBA分组的。 包括考虑后面来人的。 先占个位。[


Book1.zip (0 Bytes, 下载次数: 5)
回复 支持 反对

使用道具 举报

发表于 2012-3-8 15:46:14 | 显示全部楼层
wmhlwx 发表于 2012-3-8 11:06
那我写个VBA分组的。 包括考虑后面来人的。 先占个位。[

Book2.zip (22.25 KB, 下载次数: 9)

点评

而且你这个并非真正的随机……  发表于 2012-3-8 19:07
以初级班的水准来看,已经很不错了,不过代码还存在很大的优化空间  发表于 2012-3-8 19:03

评分

参与人数 1登攀 +5 收起 理由
hustnzj + 5 赞一个!

查看全部评分

回复 支持 反对

使用道具 举报

发表于 2012-3-8 20:24:01 | 显示全部楼层
本帖最后由 wmhlwx 于 2012-3-9 10:31 编辑

请指点哪儿不是真正的随机。 只是有一点,如果后来只加1个人的话。我就挑最靠近的人少的一组塞进去。 但是这个时候因为组长是随机的。也算公平吧。

随机算法想了很久。

赋值确实可以优化,一个一个用CELL抡过去,估计也比我那写法好看。 速度应该还可以。

你说的是加上randomize吧。 那不是每次打开都乱序。。。。 把里面randomize前面那个'删掉就可以了。

点评

谁说是用cell抡过去的?  发表于 2012-3-11 11:47
唉,你仔细看下我的小小思考题  发表于 2012-3-8 20:27
回复 支持 反对

使用道具 举报

发表于 2012-3-11 11:33:10 | 显示全部楼层
本帖最后由 xiaofx11 于 2012-3-11 16:12 编辑

我也写了一个,但是没有考虑后期人员加入的问题,只能算个半成品吧


  1. Sub 班委()
  2. '--------冒泡排序法
  3. Dim aStr As String, bStr As String
  4. Dim arr, brr, crr()
  5. Dim i As Integer, j As Integer, m As Integer, n As Integer
  6. Dim tmp1 As Double, tmp2 As String
  7. Application.ScreenUpdating = False  '关闭屏显
  8. aStr = "加油小猫,Mas_T_er"   '正副班长
  9. bStr = "xuzi999,勤动脑体不动心,vipme,peter.mingliang"   '各组长
  10. arr = Split(aStr, ",")  '正副班写数组
  11. brr = Split(bStr, ",")  '组长写数组
  12. m = UBound(brr) + 1 '组长数量
  13. ReDim Preserve crr(1 To m, 1 To 2)  '重新定义数组
  14. For i = 1 To m  '循环
  15.     crr(i, 1) = brr(i - 1)  '组长名
  16.     crr(i, 2) = Rnd '给各组长一个随机数
  17. Next
  18. '-------以下为冒泡法
  19. '-------每个数值进行比较,重新排位
  20. For i = 1 To m - 1
  21.     For j = i + 1 To m
  22.         If crr(i, 2) > crr(j, 2) Then
  23.                 tmp1 = crr(j, 2)
  24.                 crr(j, 2) = crr(i, 2)
  25.                 crr(i, 2) = tmp1
  26.                
  27.                 tmp2 = brr(j - 1)
  28.                 brr(j - 1) = brr(i - 1)
  29.                 brr(i - 1) = tmp2
  30.         End If
  31.     Next
  32. Next
  33. Range("d1:d2") = Application.Transpose(Array("班长", "副班长"))
  34. Range("e1:e2") = Application.Transpose(arr)
  35. Range("c3").Resize(1, m) = Array("A组", "B组", "C组", "D组")
  36. Range("c4").Resize(1, m) = brr

  37. Application.ScreenUpdating = True   '恢复屏显
  38. End Sub

  39. Sub 分组()
  40. '---------工作表排序法
  41. Dim arr, brr(), crr
  42. Dim i%, j%, m%
  43. Application.ScreenUpdating = False
  44. '----把同学写入数组
  45. arr = Range(Cells(1, 1), Cells(Range("a65536").End(xlUp).Row, 1))
  46. i = UBound(arr) '数组上界

  47. ReDim Preserve arr(1 To i, 1 To 2)  '重新定义数组
  48.     For j = 2 To i  '给各同学随机数
  49.         Randomize
  50.         arr(j, 2) = Rnd()
  51.     Next
  52.    
  53.     With Range("k1")
  54.         .Resize(i, 2) = arr '把同学写入辅助单元格
  55.         .Sort key1:=Range("l1"), Header:=xlYes  '工作表排序
  56.         crr = .CurrentRegion    '重新写入数组
  57.     End With
  58.     Columns("k:l").ClearContents '清除辅助单元格
  59.     m = 1
  60.     '--------循环写入工作表
  61.     For j = 2 To i
  62.         If InStr(1, "xuzi999,勤动脑体不动心,vipme,peter.mingliang,加油小猫,Mas_T_er", _
  63.         crr(j, 1)) = 0 Then '如果不是班委
  64.             Range("c5:f15").Cells(m) = crr(j, 1)    'range的cells用法
  65.             m = m + 1
  66.         End If
  67.     Next
  68. Application.ScreenUpdating = True
  69. End Sub

  70. Sub 运行()
  71. '--------这段代码没大用,只是产生视觉效果
  72. For i = 1 To 30
  73.     For j = 1 To 5000
  74.         For x = 1 To 1000
  75.         Next
  76.     Next
  77.     班委
  78.     分组
  79. Next
  80. End Sub

  81.    
复制代码
分组.rar (17.93 KB, 下载次数: 3)

点评

不错的代码! i = UBound(arr) '数组上界,应该是笔误吧  发表于 2012-3-11 15:22
回复 支持 反对

使用道具 举报

头像被屏蔽
发表于 2012-5-8 10:51:15 | 显示全部楼层
提示: 作者被禁止或删除 内容自动屏蔽
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 入学

本版积分规则

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