学校体育比赛管理

一指禅62 · 发表于 2015-12-15 18:18

制表的全部代码

Option Explicit
Dim Sh As Worksheet
Dim Brr(), myGrade$, myNumbe$ '存放分组表数据，关联年级、项目编码
Public Sub 编制表册()
If 制表状态 Then
If MsgBox("系统检测到分组表数据。程序运行后将覆盖现有数据！" + Chr(10) + Chr(10) + _
"选择“是”继续运行程序，选择“否”结束编制表册程序。", vbQuestion + vbYesNo, "编制表册") = vbNo Then
Exit Sub
End If
End If
Application.StatusBar = "正在收集整理数据……"
Set Sh = Sheets("分组表")
Sh.Range("A1:J65536").Clear
Dim i As Long, j As Integer
Dim d As Object, arr, aa$, k
Set d = CreateObject("scripting.dictionary")
arr = Sheets("成绩表").Range("A1:G" & Sheets("成绩表").Range("A65536").End(3).Row)
For i = 2 To UBound(arr)
aa = Left(arr(i, 2), 1) & "|" & arr(i, 3) '年级名称+项目编码
If Not d.Exists(aa) Then
d(aa) = ""
End If
Next
k = d.keys
ReDim Preserve Brr(1 To 赛道数 + 2, 1 To 1)
Brr(1, 1) = "比赛分组表"
For i = 0 To d.Count - 1
Application.StatusBar = "正在编制第 " & i + 1 & " 个分组表，进度" & Format((i + 1) / d.Count * 100, "0") & "%"
myGrade = Split(k(i), "|")(0)
myNumbe = Split(k(i), "|")(1)
Call 编制一个分组表(myGrade, myNumbe)
Next
Application.StatusBar = "正在输出结果并格式化"
Call 输出结果并格式化
MsgBox "全部分组表已生成，请审核！建议在打印前，据实调整页面设置。"
Application.StatusBar = False
End Sub
Private Sub 编制一个分组表(年级 As String, 编码 As String)
Dim 名称$: 名称 = WorksheetFunction.VLookup(编码, Sheet3.Range("A:D"), 2, 0)
Dim 规则$: 规则 = WorksheetFunction.VLookup(编码, Sheet3.Range("A:D"), 3, 0)
Dim i As Long, j As Integer, iRow As Long, iCol As Integer
Dim rs As Object, SQL$
' On Error Resume Next
SQL = "select * from [成绩表$] where 班级 like '" & myGrade & "%' and 项目='" & myNumbe & "' order by 号码"
Set rs = CreateObject("Adodb.Recordset")
rs.Open SQL, cnn, 1, 3
Rem 按不同规则生成分组信息，存放到Brr
iCol = 赛道数 + 2
iRow = UBound(Brr, 2) + 2
ReDim Preserve Brr(1 To iCol, 1 To iRow)
Brr(1, iRow) = "项目：" & 年级 & "年级" & 名称
Dim P%: P = 赛道数 '一个阀值，触发动态数组增加行数
Dim Z%: rs.MoveLast: Z = rs.Fields("组别"): rs.MoveFirst '移动指针，获取最大组号
Brr(6, iRow) = "共" & Z & "组，" & rs.RecordCount & "人。"
Select Case 规则
Case "规则1"
For i = 0 To rs.RecordCount - 1
If rs.Fields("赛道") < P Then
'当前赛道值<阀值时,触发动态数组增加5行
iRow = UBound(Brr, 2)
ReDim Preserve Brr(1 To iCol, 1 To iRow + 5)
Brr(1, iRow + 1) = "组别" & rs.Fields("组别")
End If
P = rs.Fields("赛道") '阀值
Brr(2, iRow + 1) = "跑道"
Brr(2, iRow + 2) = "号码"
Brr(2, iRow + 3) = "姓名"
Brr(2, iRow + 4) = "班级"
Brr(2, iRow + 5) = "成绩"
For j = 1 To 赛道数
Brr(2 + j, iRow + 1) = j
Next
Brr(2 + rs.Fields("赛道"), iRow + 2) = rs.Fields("号码")
Brr(2 + rs.Fields("赛道"), iRow + 3) = rs.Fields("姓名")
Brr(2 + rs.Fields("赛道"), iRow + 4) = rs.Fields("班级")
rs.MoveNext
Next
Case "规则2", "规则3"
For i = 0 To rs.RecordCount - 1
If rs.Fields("赛道") < P Then
'当前赛道值<阀值时,触发动态数组增加4行
iRow = UBound(Brr, 2)
ReDim Preserve Brr(1 To iCol, 1 To iRow + 4)
Brr(1, iRow + 1) = "组别" & rs.Fields("组别")
End If
P = rs.Fields("赛道") '阀值
Brr(2, iRow + 1) = "号码"
Brr(2, iRow + 2) = "姓名"
Brr(2, iRow + 3) = "班级"
Brr(2, iRow + 4) = "成绩"
Brr(2 + rs.Fields("赛道"), iRow + 1) = rs.Fields("号码")
Brr(2 + rs.Fields("赛道"), iRow + 2) = rs.Fields("姓名")
Brr(2 + rs.Fields("赛道"), iRow + 3) = rs.Fields("班级")
rs.MoveNext
Next
Case "规则4"
Dim Sd As Integer, y%, Name
P = 0
For i = 0 To rs.RecordCount - 1
If rs.Fields("组别") <> P Then
'当前组别值<>阀值时,触发动态数组增加7行
iRow = UBound(Brr, 2)
ReDim Preserve Brr(1 To iCol, 1 To iRow + 7)
Brr(1, iRow + 1) = "组别" & rs.Fields("组别")
End If
P = rs.Fields("组别") '阀值
y = IIf(rs.Fields("赛道") = Sd, y + 1, 0)
Sd = rs.Fields("赛道")
Brr(2, iRow + 1) = "跑道"
Brr(2, iRow + 2) = "姓名"
Brr(2, iRow + 3) = "姓名"
Brr(2, iRow + 4) = "姓名"
Brr(2, iRow + 5) = "姓名"
Brr(2, iRow + 6) = "班级"
Brr(2, iRow + 7) = "成绩"
For j = 1 To 赛道数
Brr(2 + j, iRow + 1) = j
Next
Name = Split(rs.Fields("姓名"), "/")
For j = 0 To UBound(Name)
Brr(2 + rs.Fields("赛道"), iRow + y + j + 2) = Name(j)
Next
Brr(2 + rs.Fields("赛道"), iRow + 6) = rs.Fields("班级")
rs.MoveNext
Next
End Select
rs.Close
Set rs = Nothing
End Sub
Private Sub 输出结果并格式化()
Dim R As Long
Application.ScreenUpdating = False
Sh.Select
Sh.Range("A1").Resize(UBound(Brr, 2), UBound(Brr)) = WorksheetFunction.Transpose(Brr)
R = Sh.Range("B65536").End(3).Row
If R < 3 Then Exit Sub
With Sh.Range("A1").Resize(1, UBound(Brr))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Name = "黑体"
.Font.Size = 20
.Font.FontStyle = "加粗"
.Font.Underline = xlUnderlineStyleSingleAccounting
End With
Sh.Range("A3").Resize(UBound(Brr, 2) - 2, UBound(Brr)).Select
With Selection '对齐
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Selection.Font
.Name = "微软雅黑"
.Size = 10
End With
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=OR($B3=""跑道"",$B3=""号码"")"
With Selection.FormatConditions(1).Borders(xlLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.FormatConditions(1).Borders(xlRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.FormatConditions(1).Borders(xlTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.FormatConditions(1).Borders(xlBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.FormatConditions(1).Interior.ColorIndex = 15
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=AND(left($A3,2)<>""项目"",$B3<>"""")"
With Selection.FormatConditions(2).Borders(xlLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.FormatConditions(2).Borders(xlRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=left($A3,2)=""项目"""
With Selection.FormatConditions(3).Font
.Bold = True
.Italic = False
End With
Dim Rng As Range
For Each Rng In Sh.Range("B:B")
If Rng = "成绩" Then
Sh.Range("A" & Rng.Row).Resize(1, UBound(Brr)).Borders(xlEdgeBottom).LineStyle = xlContinuous
End If
Next
Sh.Range("A:A").HorizontalAlignment = xlLeft
Sh.Range("A4").Select
Application.ScreenUpdating = True
End Sub

复制代码

thzss · 发表于 2015-12-15 20:43

一指禅62精益求精，越来越方便实用，先谢过再测试

thzss · 发表于 2015-12-15 20:55

已经初步试了一下，好用！

lbay · 发表于 2015-12-16 05:51

一指禅62大师辛苦了，感谢你为大家解决难题。

ymj02042006 · 发表于 2015-12-16 07:58

学习了,谢谢

lbay · 发表于 2015-12-21 07:55

一指禅62大师你好，麻烦你帮看一下，点击“成绩管理”时，出现提示：运行时错误‘424’，再点击调试时，“frm成绩登记.Show”这个代码被标成黄色了，不知道是什么原因？先谢谢您！

一指禅62 · 发表于 2015-12-21 08:09

lbay 发表于 2015-12-21 07:55
一指禅62大师你好，麻烦你帮看一下，点击“成绩管理”时，出现提示：运行时错误‘424’，再点击调试时，“f ...

丢失了 ListView1控件。相关解决方案在论坛中搜一下。

这个也可参考一下：

http://club.excelhome.net/thread-703775-1-1.html

一指禅62 · 发表于 2015-12-21 08:45

lbay 发表于 2015-12-21 07:55
一指禅62大师你好，麻烦你帮看一下，点击“成绩管理”时，出现提示：运行时错误‘424’，再点击调试时，“f ...

   实际运用中，这种登分方式不太理想。

   我设想的方案是：按项目制作“成绩表.xls”文件，分发到各项目组，各项目组将填写好的工作簿文件返回，系统采用导入的方式批量录入成绩，快捷准确。

lbay · 发表于 2015-12-21 17:45

一指禅62 发表于 2015-12-21 08:45
实际运用中，这种登分方式不太理想。

我设想的方案是：按项目制作“成绩表.xls” ...

谢谢你！今天忙了一天，刚上来看到你的回复。

一指禅62 · 发表于 2015-12-23 13:56

一指禅62 发表于 2015-12-21 08:45
实际运用中，这种登分方式不太理想。

我设想的方案是：按项目制作“成绩表.xls” ...

已按这种方式修改，发在 1 楼（2015年12月23日）。欢迎测试并指出问题。

		自动登录	找回密码
密码			免费注册

[原创] 学校体育比赛管理

评分

评分

评分

最新热点 /1