如何根据专家库生产专家小组

starpeng0719

需求说明：1.专家库名单可以继续追加；                 2.根据随机生成条件（生成组数和每组人数），生成专家小组；


请各位专家帮助，如何实现以上需求，附表

microyip

用字典记录一下名字，按照分组数，除一下，每个组几个人，然后随机调用字典填到组里即可。这个问题好像之前也有人提出几乎一模一样的需求的

starpeng0719

microyip 发表于 2019-10-9 08:50
用字典记录一下名字，按照分组数，除一下，每个组几个人，然后随机调用字典填到组里即可。这个问题好像之前 ...

有限定条件，比如：生产组数和每组人数 都是变量，根据需要可以调整

microyip

starpeng0719 发表于 2019-10-9 09:12
有限定条件，比如：生产组数和每组人数 都是变量，根据需要可以调整

你这个所谓限定条件不影响从字典随机抽取的结果嘎

liangmutou01

分组结果在B列
Sub sjs()
  Application.ScreenUpdating = False
  h = [a65536].End(3).Row
  [b1] = "分组"
  Range("b2:b" & h).Formula = "=rand()"
  Range("a1:b" & h).Sort key1:="分组", Header:=xlYes
  Range("b2:b" & h).ClearContents
  Range("b2:b7") = "1组"
  Range("b8:b12") = "2组"
  Range("b13:b17") = "3组"
  Application.ScreenUpdating = True
End Sub

liangmutou01

把程序文件也发给你。

starpeng0719

liangmutou01 发表于 2019-10-9 09:22
分组结果在B列
Sub sjs()
  Application.ScreenUpdating = False

1.生成组数和每组人数都是变量； 如：可随意设置  5组   3人   或   3组   5人  等
2.生成的结果可以不改变原名单吗？
如结果显示：    组1：张三  李四  王二麻
                      组2：张四  李三 王二小            

网海遨游

楼主：是不是要这样的？

Sub test()
        Set sh1 = Sheets("sheet1")
        r = sh1.[A65536].End(3).Row 'a列有数据的最大行号
        Set d = CreateObject("Scripting.Dictionary") '定义字典对象
        arr = sh1.Range("a1:b" & r) '给数组arr赋值
        For i = 2 To UBound(arr) '相当于行循环
            d(arr(i, 1)) = i '写入字典“键”值，“条目”值
        Next i
        r1 = sh1.[A65536].End(3).Row - 1
        Set d1 = CreateObject("Scripting.Dictionary")
        Do Until d1.Count = 15 '设定产生个数
                s = Int(Rnd * r1 + 2)
                d1(s) = ""
        Loop
        sh1.[g2:h16].ClearContents
        brr = sh1.[g2:h16]
        For Each Rng In d1.keys
                n = n + 1
                brr(n, 1) = "第" & Int((n - 1) / 5) + 1 & "组"
                brr(n, 2) = arr(Rng, 1)
        Next Rng
        sh1.[g2].Resize(UBound(brr), 2) = brr
End Sub

microyip

1. Sub 分组()
   
2.     Dim vData As Variant, nRow As Integer, oDic As Object, sName As String
   
3.     Dim nTeams As Integer, nTeam As Integer, nPerson As Integer, nAVG As Integer
   
4.    
   
5.     With Sheet1
   
6.         nTeams = Val(.[D1].Value)
   
7.         nPerson = Val(.[H1].Value)
   
8.         If nTeams = 0 Or nPerson = 0 Then
   
9.             MsgBox "分组参数未设置！"
   
10.             Exit Sub
    
11.         End If
    
12.         vData = .[A1].CurrentRegion.Resize(, 1).Value
    
13.         Set oDic = CreateObject("Scripting.Dictionary")
    
14.         For nRow = 2 To UBound(vData)
    
15.             If Trim(vData(nRow, 1)) <> "" Then oDic(Trim(vData(nRow, 1))) = 0
    
16.         Next
    
17.         nAVG = Int((oDic.Count - 1) / nTeams) + 1
    
18.         If nAVG > nPerson Then nAVG = nPerson
    
19.         ReDim vData(1 To nTeams, 1 To nAVG)
    
20.         For nTeam = 1 To nTeams
    
21.             For nPerson = 1 To nAVG
    
22.                 If oDic.Count > 0 Then
    
23.                     Randomize
    
24.                     nRow = (oDic.Count - 1) * Rnd()
    
25.                     sName = oDic.Keys()(nRow)
    
26.                     oDic.Remove sName
    
27.                     vData(nTeam, nPerson) = sName
    
28.                 End If
    
29.             Next
    
30.         Next
    
31.     End With
    
32.     With Sheet2
    
33.         .UsedRange.ClearContents
    
34.         .[A2].Resize(nTeams, nAVG) = vData
    
35.     End With
    
36. End Sub

复制代码

microyip

附上附件以供参考