一键分析统计学生成绩及生成排好版的全年级排名表与各班表

一键分析统计学生成绩及生成排好版的全年级排名表与各班表『修正版』
可在/share/home?uk=2902695957#category/type=0下载模板及.xla文件。

分析统计各科平均分及年级平均分并生成（年名表与班名表）
'统计基础："各单科"成绩按本身降序排列取前N名或"各班"成绩按总分降序排列取前N名(包括与第N名相同总分)
*********（不用手动排序，排名，在模板上点“统”一键生成）
xel7000自动化工具.xla 模块代码：
（模板与对应源表放在同一文件夹打开会自动取得数据，工具—加载宏加载.xla）
Public Sub 每类一页() '前提是排好类别,每班1页,按性别2页
Option Explicit
Public Sub 每类一页() '前提是排好类别,每班1页,按性别2页
Application.ScreenUpdating = False
'On Error Resume Next
Dim a As Range, srange As Range, fvalue As String, c, d, fFlag, ss, i, n, p As Integer, rend, j As Long, _
sCol As Long, StartRow As Long, EndRow As Long, sc As Single
'找到分类依据********************************
fvalue = InputBox("请输入分页依据的类别", "类别", "班级")
If Len(fvalue) = 0 Then Exit Sub
For Each a In Intersect(Rows("1:4"), edRange) '只找了前4行冻结
'If (CStr(a.Value) = fvalue) Then
If StrComp(CStr(a.Value), fvalue, vbTextCompare) = 0 Then
a.Select
fFlag = 1
c = a.Row
d = a.Column
'MsgBox "查找成功"
End If
Next
If fFlag <> 1 Then MsgBox "找不到包含【" & fvalue & "】的字段单元格。

": Exit Sub
' 冻结并设置顶端标题行********************************
Rows("1:" & c).Font.Bold = True
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$" & c
.PrintTitleColumns = ""
End With
Rows(c + 1).Select
ActiveWindow.FreezePanes = True
'原稿处理********************************
ActiveSheet.Cells.Font.Size = 12
Call 原稿处理
'按类分页***************************************
'选取要分类的列
rend = ActiveSheet.Cells.Find("*", , xlValues, , xlByRows, 2).Row
Set srange = Range(Cells(c + 1, d), Cells(rend, d))
'按类分页
On Error Resume Next
ActiveSheet.ResetAllPageBreaks
n = 1
sCol = srange.Cells(1, 1).Column
StartRow = srange.Cells(1, 1).Row
EndRow = StartRow + srange.Rows.Count - 1
For j = StartRow To EndRow - 1
If StrComp(Cells(j, sCol), Cells(j + 1, sCol), vbTextCompare) <> 0 Then 'Cells(j, sCol) <> Cells(j + 1, sCol) Then
n = n + 1 '要缩放的页数
'ActiveSheet.HPageBreaks.Add Before:=Cells(j + 1, sCol)
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Cells(j + 1, sCol)
End If
Next j
ss = 100
'缩放掉多余自动分页符************************************
For i = 10 To 100
p = ExecuteExcel4Macro("Get.Document(50)")
If p <= n Then Exit For
If ActiveSheet.PageSetup.Zoom <= 10 Then ActiveSheet.PageSetup.Zoom = 100: MsgBox "无法完成缩放,已恢复到100%缩放比例！"
ss = ActiveSheet.PageSetup.Zoom - 2
ActiveSheet.PageSetup.Zoom = ss
Next
'缩放的看不清（极限）
If (Rows(c + 1).Height) * ss < 1125 Then ActiveSheet.PageSetup.Zoom = 100: MsgBox "小于（8号字体的适合行高）可能效果不太好" & vbCrLf & "已恢复到100%缩放比例！" '小于8号字体的适合行高（主要内容为最小行高的情况下）
Application.ScreenUpdating = True
End Sub
Public Sub 原稿处理()
Dim rend, cend As Long
'最大化页面设置
With ActiveSheet.PageSetup
' .LeftHeader = "" '页眉-左边位置
' .CenterHeader = '页眉-中间位置
' .RightHeader = "&D" '页眉-右边位置
' .LeftFooter = "" '页脚-左边位置
.CenterFooter = "第&P 页，共&N 页" '页脚-中间位置
' .RightFooter = "" '页脚-右边位置
.LeftMargin = Application.InchesToPoints(0) '页边距-左
.RightMargin = Application.InchesToPoints(0) '页边距-右
.TopMargin = Application.InchesToPoints(0.2) '页边距-上
.BottomMargin = Application.InchesToPoints(0.4) '页边距-下
.HeaderMargin = Application.InchesToPoints(0) '页眉
.FooterMargin = Application.InchesToPoints(0) '页脚
' .PrintHeadings = False '打印行号列号
' .PrintGridlines = False '打印网格线
' .PrintComments = xlPrintNoComments '无批注
' .CenterHorizontally = False '水平居中
' .CenterVertically = False '垂直居中
' .Orientation = xlLandscape
' .Draft = False
' .PaperSize = xlPaperA4 '纸型
' .FirstPageNumber = xlAutomatic
' .Order = xlDownThenOver
' .BlackAndWhite = False ' '单色打印
' .Zoom = 90 '缩放比例
' .PrintErrors = xlPrintErrorsDisplayed
End With
rend = ActiveSheet.Cells.Find("*", , xlValues, , xlByRows, 2).Row
cend = ActiveSheet.Cells.Find("*", , xlValues, , xlByColumns, 2).Column
Range(Cells(2, 1), Cells(rend, cend)).Borders.LineStyle = xlContinuous
Range(Cells(2, 1), Cells(rend, cend)).HorizontalAlignment = xlCenter
ActiveSheet.Rows.EntireRow.AutoFit
ActiveSheet.Columns.EntireColumn.AutoFit
End Sub
'如果是想自动取得打印时的分页符位置，并将表头真实的添加到该位置，则使用以下代码
Sub 获取分页符并添加表头()
Dim rng As Range
Dim titleRow%, hBreakNum%, i%
Set rng = Sheet2.[A1:O2] '根据实际情况设定表头区域,这里假设表头区域为[A1:H3],应用到codename为shee2的表
titleRow = 2 '根据实际情况设定表头所占的行数，这里为3行
With Sheet2
'hBreakNum = ExecuteExcel4Macro("Get.Document(50)")
hBreakNum = .HPageBreaks.Count
If hBreakNum > 0 Then
Do
.Rows(.HPageBreaks(i).Location.Row).Resize(titleRow).Insert xlShiftDown
rng.Copy .Cells(.HPageBreaks(i).Location.Row, 1)
Loop Until i = hBreakNum
End If
End With
End Sub
各班成绩分析统计.xla 模块代码
Option Explicit
Public Function 年名班名表(ch As String) As String
Dim dfname As Workbook, currenname, pname, ipath, term, midfin As String, d, tj, ctotal, cclass, rend, cend, jm As Integer, _
dyear, dmonth, dday As Long
On Error Resume Next
'On Error GoTo err
tj = Application.Text(Left(Range("b3").Value, 1), "[dbnum1]")
If ch = "y" Then pname = "年名"
If ch = "c" Then pname = "班名"
currenname = '当前执行的应是有成绩的模板表，否则空白表find处出错
'某个文件:
ipath = Workbooks(currenname).Path & "\" & "初" & tj & "年级(" & pname & ")表.xls" '文件的详细地址
Application.DisplayAlerts = False
If Dir(ipath) = "" Then
Set dfname = Workbooks.Add
Workbooks().SaveAs Filename:=Workbooks(currenname).Path & "\" & "初" & tj & "年级(" & pname & ")表.xls"
Else
Application.Workbooks.Open (Workbooks(currenname).Path & "\" & "初" & tj & "年级(" & pname & ")表.xls")
Set dfname = Workbooks("初" & tj & "年级(" & pname & ")表.xls")
End If
Application.DisplayAlerts = True
Workbooks(currenname).Activate
rend = ActiveSheet.Cells.Find("*", , xlValues, , xlByRows, 2).Row
cend = ActiveSheet.Cells.Find("*", , xlValues, , xlByColumns, 2).Column
Range(Cells(2, 1), Cells(rend, cend)).Copy
Windows("初" & tj & "年级(" & pname & ")表.xls").Activate
Range("A2").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
If ch = "y" Then
For jm = 1 To 15
If Cells(2, jm) = "总分" Then
ctotal = jm
Next
Selection.Sort Key1:=Cells(3, ctotal), Order1:=xlDescending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
rend = ActiveSheet.Cells.Find("*", , xlValues, , xlByRows, 2).Row
Cells(3, ctotal + 1).Value = 1
Range(Cells(3, ctotal + 1), Cells(rend, ctotal + 1)).DataSeries _
Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
End If
If ch = "c" Then
For jm = 1 To 15
If Cells(2, jm) = "班名" Then
cclass = jm
End If
Next
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Key2:=Cells(3, cclass), Order2:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal End If
' 第1行处理
dyear = Year(Date)
dmonth = Month(Date)
Select Case dmonth
Case 9 To 12
term = "上"
midfin = "期中"
Case 1
term = "上"
midfin = "期终"
Case 2 To 5
term = "下"
midfin = "期中"
Case 6 To 7
term = "下"
midfin = "期终"
End Select
If ch = "y" Then d = ctotal + 2
If ch = "c" Then d = cclass
Range(Cells(1, 1), Cells(1, d)).Select
With Selection
.HorizontalAlignment = xlCenter
.MergeCells = True
'.Font.Bold = True
End With
Range("a1").Value = "蓝坊初中" & (dyear - 1) & "-" & dyear & term & Left(, 2) & "年级" & midfin & "考试成绩"
'Application.CutCopyMode = False
If ch = "y" Then
ActiveSheet.Cells.Font.Size = 12
Rows("1:2").Font.Bold = True
ActiveSheet.PageSetup.PrintTitleRows = "$1:$2"
Rows("3:3").Select
ActiveWindow.FreezePanes = True
Application.Run "'" & ThisWorkbook.Path & "\xel7000自动化工具.xla'!原稿处理"
End If
If ch = "c" Then Application.Run "'" & ThisWorkbook.Path & "\xel7000自动化工具.xla'!每类一页"
'年名班名表=
'err: MsgBox "出错了": Exit Function
End Function
Public Sub 清(ByVal flag As Boolean)
'清除“姓名”字段中含“N/A”的无效数据。

'清除“姓名”字段中含“a”的暂坐生。

Dim i, j As Integer, s As String, tellme As String
If flag Then
tellme = "请输入一个暂坐生标志"
s = Application.InputBox(prompt:=tellme, Title:="暂坐生标志", Default:="A")
If Len(s) = 0 Then Exit Sub
End If
i = Range("A65536").End(xlUp).Row
For j = 1 To i
If IsError(Cells(j, 3)) Then
Rows(j).ClearContents
ElseIf flag Then
If InStr(Cells(j, 3), s) > 0 Then Rows(j).ClearContents
End If
Next
End Sub
Sub 统()
'分析统计各科平均分及年级平均分并生成（年名表与班名表）
'统计基础："各单科"成绩按本身降序排列取前N名或"各班"成绩按总分降序排列取前N名(包括与第N名相同总分)
Dim i, m, j, n, k, o, jm, zf, zh, li As Integer, currenname, flag As String, c As Range
Dim tellme, tellme1, tellme2 As String, fl As Boolean
Application.ScreenUpdating = False
'清除无效数据求出排名公式
fl = False
Application.Run "清", fl
currenname = '当前执行的应是有成绩的模板表，否则空白表find处出错
Workbooks(currenname).Activate
年名班名表("c")
Workbooks(currenname).Activate
年名班名表("y")
Workbooks(currenname).Activate
fl = True
Application.Run "清", fl
'初始化班级个数平均基数
tellme1 = "请输入一个平均基数"
tellme2 = "请输入一个正确的最大班级个数"
flag = Application.InputBox(prompt:=tellme, Title:="统计方式,各单科 1 各班2", Default:=1, Type:=1)
If flag = False Then Exit Sub
i = Application.InputBox(prompt:=tellme, Title:="平均基数", Default:=50, Type:=1)
If i = False Then Exit Sub
m = Application.InputBox(prompt:=tellme2, Title:="班级个数", Default:=6, Type:=1)
If m = False Then Exit Sub
'求各班各科平均分
'科目
Range("D2").Range("A1:I1").Select
Selection.Copy
Range("Q2").Select
Selection.PasteSpecial Paste:=xlPasteV aluesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("z2") = "政史"
'取得政史列号
For jm = 17 To 30
If Cells(2, jm) = "政治" Then
zh = jm
ElseIf Cells(2, jm) = "历史" Then
li = jm
End If
Next
For jm = 1 To 15
If Cells(2, jm) = "总分" Then zf = jm
Next
'班级
j = 1 '执行的班级个数
k = 3 '每班开始处
n = 83 '执行的求平均行号定位
o = 3 '执行聚集行号定位
While j <= m
If flag = 2 Then
Cells(n, zf).FormulaR1C1 = "=SUMPRODUCT(--(R[-80]C:R[-1]C>=LARGE(R[-80]C:R[-1]C, " & i & " )))"
i = Cells(n, zf).Value
Cells(n, 4).FormulaR1C1 = "=SUMPRODUCT(--(R[-80]C" & zf & " :R[-1]C" & zf & " >=LARGE(R[-80]C" & zf & " :R[-1]C" & zf & "," & i & "))*R[-80]C:R[-1]C)/" & i & " "
End If
If flag = 1 Then Range("d" & n & "").FormulaArray = "=A VERAGE(LARGE(R[-80]C:R[-1]C,ROW(R1:R" & i & ")))"
Range("d" & n & "").Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:I1"), Type:= _
xlFillDefault
ActiveCell.Range("A1:I1").Select
Selection.Copy
Range("q" & o & "").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("z" & o & "").Select
On Error Resume Next
ActiveCell.FormulaR1C1 = Application.WorksheetFunction.Sum(Cells(o, zh), Cells(o, li))
k = n + 1
n = n + 81
j = j + 1
o = o + 1
Wend
'求年平均分
Range("q" & o & "").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-" & m & "]C:R[-1]C)/" & m & ""
Selection.AutoFill Destination:=ActiveCell.Range("A1:J1"), Type:= _
xlFillDefault
ActiveCell.Offset(0, -1).Range("A1").Select
ActiveCell.FormulaR1C1 = "年平"
'设置格式为“2”位小数（红色）
Range("Q3:Z12").Select
Selection.NumberFormatLocal = "[红色]0.00_ ;[红色]-0.00 "
'清空多余列
For jm = 17 To 30
If Cells(2, jm) = "总分" Then
Columns(jm).ClearContents
ElseIf Cells(2, jm) = "年名" Then
Columns(jm).ClearContents
ElseIf Cells(2, jm) = "班名" Then
Columns(jm).ClearContents
End If
Next
'清空无效数据
For Each c In Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)) If IsError(c) Then
c.ClearContents
End If
Next c
End Sub
菜单与工具栏代码：略。