ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: gensen

[求助] 请教一个随机分组的问题

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-9-30 13:34 | 显示全部楼层
见附件
  1. Sub Generate20RandArray()
  2.     Dim arr(1 To 100), brr
  3.     Dim gdArr(24), bgdArr(74), bgdArr1(), tempArr(49), tempArr1()
  4.     Dim rArr(1 To 50, 1 To 20)
  5.    
  6.     For i = 1 To 100
  7.         arr(i) = i
  8.     Next
  9.     brr = RandSortForArray(arr)
  10. '    Range("A1").Resize(100, 1) = Application.Transpose(brr)
  11.     For i = 0 To 99
  12.         If i < 25 Then
  13.             gdArr(i) = brr(i)
  14.         Else
  15.             bgdArr(i - 25) = brr(i)
  16.         End If
  17.     Next
  18.    
  19.     Range("A58").Resize(25, 1) = Application.Transpose(gdArr)
  20.    
  21.     For i = 1 To 20
  22.         For j = 1 To 25
  23.             tempArr(j - 1) = gdArr(j - 1)
  24.         Next j
  25.         bgdArr1 = RandSortForArray(bgdArr)
  26.         For j = 26 To 50
  27.             tempArr(j - 1) = bgdArr1(j - 26)
  28.         Next
  29.         tempArr1 = RandSortForArray(tempArr)
  30.         For j = 1 To 50
  31.             rArr(j, i) = tempArr1(j - 1)
  32.         Next j
  33.     Next
  34.    
  35.     Range("A3").Resize(50, 20) = rArr
  36. End Sub

  37. '数组排序,只接受一维数组
  38. Public Function RandSortForArray(ByRef RawArray())
  39.     Dim arr, u&, l&, num&
  40.         
  41.     u = UBound(RawArray): l = LBound(RawArray)
  42.     num = u - l + 1
  43.    
  44.     Set d = CreateObject("Scripting.Dictionary")
  45.     '数组中的值去重
  46.     For i = 1 To num
  47.         If Len(RawArray(l + i - 1)) Then
  48.             d(RawArray(l + i - 1)) = ""
  49.         End If
  50.     Next
  51.     num = d.Count
  52.     arr = d.keys
  53.     d.RemoveAll
  54.    
  55.     '随机排序
  56.     Do Until d.Count = num
  57.         d(arr(Int(Rnd() * num))) = ""
  58.     Loop
  59.     arr = d.keys
  60.    
  61.     Set d = Nothing
  62.     RandSortForArray = arr
  63. End Function
复制代码


随机20组.rar

21.21 KB, 下载次数: 11

TA的精华主题

TA的得分主题

发表于 2018-9-30 13:39 | 显示全部楼层
本帖最后由 一把小刀闯天下 于 2018-9-30 13:43 编辑

'至少25个相同

'如果只有25个相同应该无解,因为至少需要525个数才会有解,除非每组可以有相同的数

Option Explicit

Sub test()
  Dim arr, i, j, n, t
  ReDim arr(1 To 100)
  For i = 1 To 100: arr(i) = i: Next
  ReDim brr(1 To 50, 1 To 20)
  Randomize
  For i = 1 To UBound(arr, 1)
    n = Int(Rnd * 100) + 1
    t = arr(i): arr(i) = arr(n): arr(n) = t
  Next
  For i = 1 To 25
    For j = 1 To UBound(brr, 2): brr(i, j) = arr(i): Next
  Next
  For j = 1 To UBound(brr, 2)
    For i = 26 To UBound(brr, 1)
      n = Int(Rnd * (100 - i + 1)) + i
      t = arr(i): arr(i) = arr(n): arr(n) = t
      brr(i, j) = arr(i)
  Next i, j
  For j = 1 To UBound(brr, 2)
    For i = 1 To UBound(brr, 1)
      n = Int(Rnd * UBound(brr, 1)) + 1
      t = brr(i, j): brr(i, j) = brr(n, j): brr(n, j) = t
  Next i, j
  [a1].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-30 13:49 | 显示全部楼层
zopey 发表于 2018-9-30 12:50
为了证明20组数 有解,你先把4楼 的 第4组 数 找出来。

你把1-25固定,然后剩余25个数字等于就从26-100之间组合了,这样找组合就太简单了,虽然满足我的条件,但这样得出的组合就没有意义了,也许我开始还没表达清楚,应该再加一条不能让20组里面的数字都有固定一样的25个相同数字。

比如下面是我手工找的四组号码就符合这个要求,但是再手工找下去就不好找了
第一组:1-50
第二组:全单1 3 5 7 ... ... 95 97 99
第三组:1-25 + 76-100
第四组:1-12 + 25-37+51-62 +74 + 77-88
这四组任意一组和其他两组比较都有25个相同数字,但又都不是固定的25个相同数字,这样的组合才我想要找的组合。
谢谢你!

TA的精华主题

TA的得分主题

发表于 2018-9-30 13:52 | 显示全部楼层
一把小刀闯天下 发表于 2018-9-30 13:39
'至少25个相同

'如果只有25个相同应该无解,因为至少需要525个数才会有解,除非每组可以有相同的数

楼主说的是“要求任何一组与其他19组比较都是有25个数相同”(即全部数组里出现20次),另外数字只要不是每组都有就可以了(即全部数组里出现小于20次)。

因此,楼主的要求是可以实现的。

TA的精华主题

TA的得分主题

发表于 2018-9-30 14:00 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
mzbao 发表于 2018-9-30 13:52
楼主说的是“要求任何一组与其他19组比较都是有25个数相同”(即全部数组里出现20次),另外数字只要不是 ...

嗯,又看了一遍题,确实是理解错了

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-30 14:00 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

谢谢你的热心解答。但是好像还没完全满足要求,这样等于是先固定好25个数,然后再在剩余的75个数里面去组合剩下的25个数。可能是我开始还没表达清楚,应该再加上一条,不能每组都是一模一样相同的25个数字,比如我自己手工组合了四组:
第一组:1-50
第二组:全单1 3 5 7 。。。。。。95 97 99
第三组:1-25 + 76-100
第四组:1-12 + 25-37 + 51-62 + 74 +77-88
这四组里任意一组都和其他三组有25个相同数字,但又不是固定的25个数,能否像这样再找16组出来吗?谢谢!

TA的精华主题

TA的得分主题

发表于 2018-9-30 14:50 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
gensen 发表于 2018-9-30 14:00
谢谢你的热心解答。但是好像还没完全满足要求,这样等于是先固定好25个数,然后再在剩余的75个数里面去组 ...

我附件里25个相同数字不是固定的,也是随机的。只是没事随机的时候,先固定这25个随机的相同数字。但是每次执行的时候,这25个会变的。

TA的精华主题

TA的得分主题

发表于 2018-9-30 14:56 | 显示全部楼层
本帖最后由 mzbao 于 2018-9-30 15:06 编辑
gensen 发表于 2018-9-30 14:00
谢谢你的热心解答。但是好像还没完全满足要求,这样等于是先固定好25个数,然后再在剩余的75个数里面去组 ...

我好想有点理解你的意思了,意思每2组之间有相同25个就行了。
那这样好像变成其它坛友的理解的一样了,如果每两组之间只能25个相同,好像变得不太可能了。

TA的精华主题

TA的得分主题

发表于 2018-9-30 15:14 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 香川群子 于 2018-9-30 15:35 编辑
mzbao 发表于 2018-9-30 13:52
楼主说的是“要求任何一组与其他19组比较都是有25个数相同”(即全部数组里出现20次),另外数字只要不是 ...

有意思的是,这25个相同数必然完全相同。
即,20组中,有且只有这25个数,是完全相同的,不会多一个,也不会少一个。

因此,固定25个随机数之后,剩余25个数随机选择就可以了。

……
这个是否属于巧合,未经思考和验证。

补充:
确实如此,原因很简单,要求的相同数和组数越多,则趋同性越强。
测试结果,如果条件同样是100个数中随机取50个数为一组,且要求每一组都有25个数相同,那么最多能在只取小于7组时,可以得到每组相同数总范围高于25个的情况。(即有多于25个数在各组都有出现)

又如,只取4组时,不同的相同数可能会有28个。
只取3组时,不同的相同数可能会超过30个。
……

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-30 15:29 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
mzbao 发表于 2018-9-30 14:56
我好想有点理解你的意思了,意思每2组之间有相同25个就行了。
那这样好像变成其它坛友的理解的一样了, ...

嗯,是的,两组之间有25个相同数就可以,但各组不能都是完全固定一模一样的25个数字。

这个是可能的,因为我用20个数字组合10个数字为一组,每组之间都有5个相同数,这样都能组合出符合要求的15个组合,何况100个数字组合50个,这样更可以组合出来,就是不知道如何写代码。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2025-1-16 12:54 , Processed in 0.024766 second(s), 7 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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