|
|
楼主 |
发表于 2015-12-15 18:18
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
制表的全部代码
- 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
|
评分
-
1
查看全部评分
-
|
楼主: 一指禅62
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2015-12-15 20:43
