|
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 Sub
2、在工作表“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 Sub
3、在模块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
| 安利小店
安利的牙膏非常不错，用了以后就不想再用其他的了；洗洁精、洗衣液也是日常必备，用过都说好！ | | 合谷医疗
合谷医疗专攻各种疑难杂症，尤其擅长腰颈椎疾病、儿童神经发育异常、多动症、自闭孤独症治疗，可谓神乎其技！体验过的直呼早点来就好了！ | | 我的付费知识星球：Excel活学活用
帮助VBA初学者提高VBA编程水平，欢迎加入！
|
喜欢就点个赞、点在看、留言评论、分享一下呗！感谢支持！ 案例文件分享说明： 案例文件可免费分享，但需符合以下要求：
请关注、点赞、点在看、点...、留言，方便的话分享一下就完美啦！如果不便走上面的“流程”，请打赏，万分感谢！ 请添加上方我的合谷医疗企业微信，案例文件通过微信发送。如有定制需求，亦可通过微信联系。 Excel问题，请在文章下面留言讨论！或者加入我的付费知识星球免费提问！
|
