求助：分组抽签

LIUZHU

附件，WPS打开测试

一指禅62

1. 
   
2. Sub 抽签分组()
   
3.     Dim arr, i%, x%, temp
   
4.     arr = Sheet1.Range("L8:L32").Value
   
5.     ReDim a(1 To UBound(arr), 1 To 1)
   
6.     Rem 抽签开始，ShuffleArr  洗牌
   
7.     For i = 1 To UBound(arr)
   
8.         a(i, 1) = arr(i, 1)                         '随机序号
   
9.     Next
   
10.     Randomize
    
11.     For i = 1 To UBound(arr)                        '洗牌
    
12.         x = Int(Rnd * (UBound(arr) - i + 1)) + i    '随机位置
    
13.         temp = a(x, 1)                              '暂存被抽中的数
    
14.         a(x, 1) = a(i, 1)
    
15.         a(i, 1) = temp
    
16.     Next
    
17.     Sheet1.Range("O8").Resize(UBound(arr), 1) = a
    
18. End Sub

复制代码

一指禅62

洗牌算法，简单粗暴，但基本有效。刚好最近我在琢磨这个

micch

修正一下，忘了删除已选的人

micch

还是不写通用的了，纯粹用字典随机去重练习一下吧

Sub Main()
    c = Right(Application.Caller, 1)
    Dim d As Dictionary
    Set d = ReadPlayers
    Dim Res(1 To 28, 1 To 1)
    Randomize
    For i = 1 To 7
        s = "" '已选省
        j = 0: k = IIf(i < 5, 4, 3): n = 0
        Do While j < k
            m = Int(Rnd * d.Count)
            x = d.Keys(m)
            If InStr(s, d(x)) = 0 Then
                j = j + 1
                s = s & d(x)
                Res((i - 1) * 4 + j, 1) = x
                d.Remove x
            End If
            n = n + 1
            If n > 9999 Then End
        Loop
    Next
    Cells(8, 1 + c).Resize(28).Value = Res
End Sub
Function ReadPlayers() As Dictionary
    Dim d As New Dictionary
    ar = Range("l8:l32").Value
    For Each x In ar
        d.Add x, Left(x, 1)
    Next
    Set ReadPlayers = d
End Function

micch

LIUZHU

一指禅62 发表于 2024-6-12 20:12

同一省分的队伍不在同一分组，这个没体现吧

LIUZHU

micch 发表于 2024-6-12 21:14
还是不写通用的了，纯粹用字典随机去重练习一下吧

请教下，第二行代码是什么意思？

micch

LIUZHU 发表于 2024-6-12 22:53
请教下，第二行代码是什么意思？

3个按钮共用同一个sub过程，根据点击形状的名称，判断输出在哪一列

LIUZHU

micch 发表于 2024-6-12 21:13
修正一下，忘了删除已选的人

对排除相同省分的办法，n在9999次以内，就一定会得到不同省分的吗？