|
|
楼主 |
发表于 2015-12-15 18:17
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
分组的全部代码
- Option Explicit
- Dim 年级$, 编码$, 规则$
- Dim rs As Object, Brr() 'Brr缓存数组
- Dim Itemp() '缓存组号赛道号
- Dim Pd% '赛道数，用InputBox方法赋值
- Dim YuJin As Boolean 'True 标记为不要第一赛道
- Public Sub 计算机分组()
- Dim i As Long, j As Integer, Msg As String
- YuJin = False
- If 报名状态 = False Then Exit Sub
- If 接力赛人数校验 = False Then Exit Sub
- If Sheet8.Range("A65536").End(3).Row > 1 Then
- Msg = MsgBox("重要提示：执行分组操作后，现有的分组及成绩将被清除，相应的秩序册将作废！请慎重选择！", _
- vbQuestion + vbYesNo, "比赛编组")
- If Msg = vbNo Then Exit Sub
- End If
-
- If Sheet7.Range("IV1") <> "" Then
- Msg = InputBox("密码：", "比赛编组数据保护")
- If StrPtr(Msg) = 0 Then Exit Sub
- If Sheet7.Range("IV1") <> Msg Then MsgBox "密码错误。项目编组失败！": Exit Sub
- End If
- Pd = InputBox("请确定启用的跑道条数(不少于2条）：", "跑道条数", 8)
- If StrPtr(Pd) = 0 Then Exit Sub
- If Pd < 2 Then MsgBox "跑道条数不符合系统要求，程序强制退出": Exit Sub
-
- Sheet8.Range("A2:H65536").ClearContents
-
- Msg = MsgBox("【4×100米接力】和【4×100米篮球接力】项目，" & _
- "在每组代表队数少于跑道数2个及以上时，可以选择不要第1道。" & _
- Chr(10) + Chr(10) & "选择“是”从第2道开始编排。", vbQuestion + vbYesNo)
- If Msg = vbYes Then YuJin = True
-
- On Error GoTo ErrExit '未知错误
- ReDim Brr(1 To 7, 1 To 1) '缓存数组
- Brr(1, 1) = "姓名": Brr(2, 1) = "班级": Brr(3, 1) = "项目": Brr(4, 1) = "号码"
- Brr(5, 1) = "组别": Brr(6, 1) = "赛道": Brr(7, 1) = "成绩"
- Dim arr: arr = Sheet3.Range("A1").CurrentRegion
- Dim S%, S1%: S = UBound(Grade) * UBound(arr)
- For j = 1 To UBound(Grade) '直接调用自定义函数（年级）
- 年级 = Left(Grade(j), 1)
- For i = 2 To UBound(arr)
- S1 = S1 + 1
- 编码 = arr(i, 1)
- 规则 = arr(i, 3)
- Call 编制一个比赛组
- Application.StatusBar = "进度" & Format(S1 / S * 100, "0") & "% 正在编制 " & 年级 & "年级" & arr(i, 2)
- Next
- Next
-
- Sheet8.Range("A1").Resize(UBound(Brr, 2), UBound(Brr)) = WorksheetFunction.Transpose(Brr)
- Sheet8.Visible = 0
- Application.StatusBar = False
- Erase Brr: Erase Itemp '清空数组
- 100:
- Msg = InputBox("比赛编组完成。请输入数据保护密码：", "比赛编组数据保护")
- If StrPtr(Msg) = 0 Then GoTo 100
- Sheet7.Unprotect
- Sheet7.Range("IV1") = Msg
- Sheet7.Protect
- Exit Sub
- ErrExit:
- Erase Brr: Erase Itemp '清空数组
- MsgBox "出现未知错误，比赛编组失败！"
- End Sub
- Private Sub 编制一个比赛组()
- Dim i As Long, j As Integer
- Rem 提取参加这个比赛组的运动员
- Dim SQL$, n As Long, d As Object
- Set rs = CreateObject("Adodb.Recordset")
- SQL = "select * from [报名表$] where 班级 like '" & 年级 & "%' and 项目编码 like '%" & 编码 & "%'"
- rs.Open SQL, cnn, 1, 3
- If rs.RecordCount > 0 Then
- ReDim temp(1 To 2, 1 To rs.RecordCount) '数组，临时存放
- For i = 0 To rs.RecordCount - 1
- temp(1, i + 1) = rs!姓名
- temp(2, i + 1) = rs!班级
- rs.MoveNext
- Next
- Rem 选手无序排列
- Dim crr(1 To 2), Index As Integer
- For i = 1 To rs.RecordCount
- Randomize
- Index = Int(Rnd * rs.RecordCount) + 1
- crr(1) = temp(1, i): temp(1, i) = temp(1, Index)
- crr(2) = temp(2, i): temp(2, i) = temp(2, Index)
- temp(1, Index) = crr(1) '姓名
- temp(2, Index) = crr(2) '班级
- Next
- Rem 接力赛按班级随机分组
- Dim k, t
- If 规则 = "规则4" Then
- Set d = CreateObject("Scripting.Dictionary") '接力赛
- For i = 1 To UBound(temp, 2)
- If Not d.Exists(temp(2, i)) Then
- d(temp(2, i)) = temp(1, i)
- Else
- d(temp(2, i)) = d(temp(2, i)) & "/" & temp(1, i)
- End If
- Next
- k = d.keys: t = d.items
- ReDim temp(1 To 2, 1 To d.Count) '数组，临时存放
- For i = 0 To d.Count - 1
- temp(1, i + 1) = t(i)
- temp(2, i + 1) = k(i)
- Next
- End If
- Set d = Nothing
- Rem 存放到数组
- Dim S As Long: S = UBound(Brr, 2)
- Dim iRow As Integer: iRow = UBound(temp, 2) ' rs.RecordCount
- ReDim Preserve Brr(1 To 7, 1 To iRow + S)
- ' On Error Resume Next
- Call 组号道号(iRow)
- For i = 1 To iRow
- n = S + i
- Brr(1, n) = temp(1, i) '姓名
- Brr(2, n) = temp(2, i) '班级
- Brr(3, n) = 编码 '项目
- Brr(4, n) = i '号码
- If 规则 = "规则3" Then
- Brr(5, n) = 1 '组别
- Brr(6, n) = ((i - 1) Mod Pd) + 1 '赛道
- Else
- Brr(5, n) = Itemp(1, i) '组别
-
- Brr(6, n) = Itemp(2, i) '赛道
- End If
- Next
- End If
- rs.Close: Set rs = Nothing
- Erase temp
- End Sub
- Private Sub 组号道号(iCount As Integer)
- Dim i%, j%, n%, Pd1%
- Dim Zs%, Ys%, a()
- Pd1 = Pd
- If 规则 = "规则2" Then Pd1 = Pd * 5
- ReDim Itemp(1 To 2, 1 To iCount)
- If iCount <= Pd1 Then
- For i = 1 To iCount
- Itemp(1, i) = 1 '组号
- Itemp(2, i) = ((i - 1) Mod Pd) + 1 '道号
- Next
- Else
- Zs = WorksheetFunction.RoundUp(iCount / Pd1, 0) '组数
- ReDim a(1 To Zs) '每组人数
- For i = 1 To Zs
- a(i) = iCount \ Zs '写入平均数
- Next
- Ys = iCount - (iCount \ Zs) * Zs '余数
- If Ys > 0 Then '把余数从前往后依次+1
- For i = 1 To Ys
- a(i) = a(i) + 1
- Next
- End If
- For i = 1 To UBound(a)
- For j = 1 To a(i)
- n = n + 1
- Itemp(1, n) = i '组号
- Itemp(2, n) = ((j - 1) Mod Pd) + 1 '道号
- If 规则 = "规则4" Then
- If YuJin And a(i) < Pd Then
- Itemp(2, n) = ((j - 1) Mod Pd) + 2 '道号
- Else
-
- End If
- End If
- Next
- Next
- End If
- End Sub
- Private Function 接力赛人数校验() As Boolean
- 接力赛人数校验 = True
- Dim arr(), i%, n%, rs As Object, SQL$
- Set rs = CreateObject("Adodb.Recordset")
- SQL = "select 班级,Count(*) as a,'男子4×100米接力' as b from [报名表$] where 项目编码 like '%A07%' Group by 班级"
- SQL = SQL & " Union all select 班级,Count(*) as a,'男子4×100米蓝球接力' as b from [报名表$] where 项目编码 like '%A08%' Group by 班级"
- SQL = SQL & " Union all select 班级,Count(*) as a,'女子4×100米接力' as b from [报名表$] where 项目编码 like '%B07%' Group by 班级"
- SQL = SQL & " Union all select 班级,Count(*) as a,'女子4×100米蓝球接力' as b from [报名表$] where 项目编码 like '%B08%' Group by 班级"
- rs.Open SQL, cnn, 1, 3
- If rs.RecordCount > 0 Then
- For i = 0 To rs.RecordCount - 1
- If rs!a > 0 And rs!a <> 4 Then
- n = n + 1: ReDim Preserve arr(1 To n)
- arr(n) = rs!班级 & " " & rs!B & " " & rs!a & " 名"
- 接力赛人数校验 = False
- End If
- rs.MoveNext
- Next
- End If
- rs.Close
- Set rs = Nothing
- If 接力赛人数校验 = False Then
- MsgBox "接力赛人数错误，请修正报名人数！" + Chr(10) + Chr(10) + Join(arr, Chr(10)), vbExclamation, "接力赛人数校验"
- frm报名管理.Show
- End If
- End Function
|
评分
-
1
查看全部评分
-
|
楼主: 一指禅62
[复制链接]
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2015-12-5 10:41
