【原】【代码】体育比赛分组抽签：巧用SortedList实现随机分组，同一单位不在同一组！不用数组排序！

冷茶视界

2024-06-15

发布于江苏 | 转藏

大

中

小

展开全文

点【关于本公众号】了解一下，欢迎关注，谢谢！快速浏览

实用案例

|日期控件||简单的收发存||收费管理系(Access改进版)|

|电子发票管理助手||电子发票登记系统(Access版)|

|文件合并||表格拆分||审计凭证抽查底稿|

|中医诊所收费系统(Excel版)||中医诊所收费系统(Access版)||银行对账单自动勾对|

|印章使用登记系统|

收费使用项目

|财务管理系统||工资薪金和年终奖个税筹划||新税法下工资表模版|

内容提要

体育比赛分组抽签|完整代码1、在工作表“Sheet1”里，shpClick过程，为三个形状共同指定的宏，调用randGroup过程。

Sub shapeClick() Dim shp As Shape Dim raceName As String, tempInput As String Dim cell As Range, currCell As Range, rng As Range Dim Groups As Long, lastRow As Long '//获取当前点击形状 Set shp = ActiveSheet.Shapes(Application.Caller) '//形状文本 raceName = shp.TextFrame.Characters.Text '//找到左侧对应表头单元格 For Each cell In Range("B7:D7").Cells If InStr(raceName, cell.Value) > 0 Then Set rng = cell Exit For End If Next If Not rng Is Nothing Then '//找到对应单元格，输入分组数，默认为7 tempInput = InputBox("请输入分组数：", "请入分组数", 7) If Val(tempInput) = 0 Then MsgBox "请输入一个大于0的数字！" Exit Sub Else Groups = Int(tempInput) End If '//清除数据 lastRow = UsedRange.Rows.Count rng.Offset(1).Resize(lastRow, 1).ClearContents '//执行100次随机分组 For i = 1 To 100 Call randGroup(rng, Groups) Next End IfEnd Sub2、在工作表“Sheet1”里，randGroup过程，执行随机分组。Private Sub randGroup(ByVal rng As Range, Groups As Long) Dim lastRow As Long, lastCol As Long Dim arr(), temp() Dim members As Long Dim i As Long, j As Long, k As Long Dim currRow As Long Dim sList As Object, sKey1 As String, sKey2 As String, ID As String Dim strUnit As String, strName As String Set sList = CreateObject("System.Collections.SortedList") lastRow = Cells(Rows.Count, 1).End(xlUp).Row lastCol = UsedRange.Columns.Count '//每组最多成员数 members = Application.WorksheetFunction.RoundUp((lastRow - 7) / Groups, 0) arr = Range(Cells(8, "K"), Cells(lastRow, lastCol)).Value '//排序，按单位随机排序，存入sList For i = 1 To UBound(arr) '//省份列，合并单元格 If arr(i, 3) <> "" Then strUnit = arr(i, 3) End If strName = arr(i, 2) '//一个省份只能有一个key,如果已经添加过，则需要找到已添加省份的key sKey1 = getSortedListKey(sList, "|" & strUnit & "|") If sKey1 = "" Then ID = Format(Application.WorksheetFunction.RandBetween(1, 1000), "0000") sKey1 = ID & "|" & strUnit & "|" sList.Add sKey1, CreateObject("System.Collections.SortedList") ID = Format(Application.WorksheetFunction.RandBetween(1001, 2000), "0000") sKey2 = ID & "|" & strName sList(sKey1)(sKey2) = "" Else ID = Format(Application.WorksheetFunction.RandBetween(1001, 2000), "0000") sKey2 = ID & "|" & strName sList(sKey1)(sKey2) = "" End If Next '//单位随机排序后，再回写到arr k = 1 For i = 0 To sList.Count - 1 sKey1 = sList.getkey(i) For j = 0 To sList(sKey1).Count - 1 sKey2 = sList(sKey1).getkey(j) arr(k, 2) = Split(sKey2, "|")(1) arr(k, 3) = Split(sKey1, "|")(1) k = k + 1 Next Next lastRow = UBound(arr) ReDim temp(1 To members * Groups, 1 To 1) '//分组，出场次序给个随机数 k = 1 For i = 1 To Groups For m = 1 To members currRow = Groups * (m - 1) + i If currRow > lastRow Then temp(k, 1) = "" Else temp(k, 1) = arr(currRow, 2) End If k = k + 1 Next Next Set rng = rng.Offset(1).Resize(Groups * members, 1) rng.Value = temp 'MsgBox "分组完成！"End Sub3、在模块myModule里，getSortedListKey过程，根据一个字符串，取得sList中包含该字符串的key。Function getSortedListKey(sList As Object, strPart As String) As String '//根据部分字段，匹配完整的key Dim key As Variant getSortedListKey = "" '检查 sList 是否为空 If sList Is Nothing Or sList.Count = 0 Then getSortedListKey = "" Exit Function End If '检查 strPart 是否存在于 sList 的某个键中 For i = 0 To sList.Count - 1 key = sList.getkey(i) If InStr(key, strPart) > 0 Then getSortedListKey = key Exit Function End If NextEnd Function~~~~~~End~~~~~~

安利小店安利的牙膏非常不错，用了以后就不想再用其他的了；洗洁精、洗衣液也是日常必备，用过都说好！

合谷医疗合谷医疗专攻各种疑难杂症，尤其擅长腰颈椎疾病、儿童神经发育异常、多动症、自闭孤独症治疗，可谓神乎其技！体验过的直呼早点来就好了！

我的付费知识星球：Excel活学活用帮助VBA初学者提高VBA编程水平，欢迎加入！喜欢就点个赞、点在看、留言评论、分享一下呗！感谢支持！

案例文件分享说明：

案例文件可免费分享，但需符合以下要求：

请关注、点赞、点在看、点...、留言，方便的话分享一下就完美啦！如果不便走上面的“流程”，请打赏，万分感谢！

请添加上方我的合谷医疗企业微信，案例文件通过微信发送。如有定制需求，亦可通过微信联系。

Excel问题，请在文章下面留言讨论！或者加入我的付费知识星球免费提问！