一键分析统计学生成绩及生成排好版的全年级排名表与各班表
可在pan.baidu/share/link?shareid=458047&uk=2902695957下载模板及.xla文件。
分析统计各科平均分及年级平均分并生成（年名表与班名表）
'统计基础："各单科"成绩按本身降序排列取前N名 或 "各班"成绩按总分降序排列取前N名(包括与第N名相同总分)
*********（不用手动排序，排名，在模板上点“统”一键生成）
xel7000自动化工具.xla 模块代码：
（模板与对应源表放在同一文件夹打开会自动取得数据，工具—加载宏 加载.xla）
Option Explicit
Public Sub 每类一页（） '前提是排好类别,每班1页,按性别2页
Application.ScreenUpdating = False
'On Error Resume Next
Dim a, 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"), ActiveSheet.UsedRange)
If StrComp(a.Value, fvalue, vbTextCompare) = 0 Then
a.Select
fFlag = 1
c = a.Row
d = a.Column
'MsgBox "查成功"
excel自动生成排名 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 = 100 To 10 - 1
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 - 1
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
版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。
发表评论