Attribute VB_Name = "模块1"
Public classCount As Integer
Public sheetName As String
'作者 Xian云
'日期 2018-5-3
'程序非万能,必要请手动
'若工作表处于保护状态,则程序无法读取并修改,请取消保护并保存,以使用此程序
Sub 成绩统计自动化()
'以下两行代码为了提高运算速度,暂时关闭掉屏幕上的效果显示,计算结束后恢复
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim sql As String
Dim className As String
sheetName = InputBox("请输入要统计的表的名字(如sheet1)", "需要您的输入")
classCount = Val(InputBox("请输入班级总数", "需要您的输入"))
' sheetName = "1次月考总成绩"
' classCount = 16
Dim i As Integer
For i = 1 To classCount
className = i & "班"
sql = "select * from [" + sheetName + "$] where 班级 = """ & className & """" + "order by 总分 desc"
Call sqlExe(sql, className)
scoreCalc (className)
Next
'恢复屏幕显示,恢复计算
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.Calculate
End Sub
'统计指定表的成绩并返回
Function scoreCalc(table As String)
'若考试科目增加或修改,只需要修改下面的数组中的科目信息,注意英文引号及逗号
classNames = Array("语文", "数学", "英语", "思品", "历史", "地理", "生物")
Dim name As String
Dim flg As Boolean
Dim col As Integer, row As Integer, getIndex As Integer, Count As Integer
Dim i As Integer, j As Integer
col = ActiveWorkbook.Worksheets(table).UsedRange.Columns.Count
row = ActiveWorkbook.Worksheets(table).UsedRange.Rows.Count
flg = True
Count = 0
For i = 1 To col
name = ActiveWorkbook.Worksheets(table).UsedRange.Cells(1, i)
getIndex = -1
'找到成绩列
For j = 0 To 6
If classNames(j) = name Then
getIndex = j
Exit For
End If
Next j
If getIndex <> -1 Then
Call colWidth(i, 5)
If flg Then
Call setTitle(table, i, row, "平均分")
Call setTitle(table, i, row + 1, "及格率")
Call setTitle(table, i, row + 2, "优秀率")
flg = False
End If
Call setAvg(table, i, row)
Call setPassing(table, i, row + 1)
Call setExcellent(table, i, row + 2)
Else
If name = "班级" Then Call colWidth(i, 4.25)
If name = "考号" Then Call colWidth(i, 11.5)
If name = "序号" Then Call colWidth(i, 3.75)
If name = "姓名" Then Call colWidth(i, 7.5)
If name = "总分" Then Call colWidth(i, 4.13)
If name = "校名次" Then Call colWidth(i, 6)
End If
Next i
End Function
'设置第i列的宽度
Sub colWidth(ByVal i As Integer, ByVal width As Single)
ColumnName = Chr(i + Asc("A") - 1)
Columns(ColumnName & ":" & ColumnName).Select
Selection.ColumnWidth = width
End Sub
Sub setTitle(table As String, ByVal i As String, row As Integer, ByVal title As String)
c = Chr(i + Asc("A") - 2)
Range(c & (row + 1)).Select
Application.Worksheets(table).Range(c & (row + 1)).Clear
Application.Worksheets(table).Range(c & (row + 1)).FormulaR1C1 = title
End Sub
'根据sql语句查询,并将结果返回,sql语句的结果须为一个整型值
Function setAvg(table As String, ByVal i As String, row As Integer) As Integer
c = Chr(i + Asc("A") - 1)
Range(c & (row + 1)).Select
sss = "=AVERAGE(R[" & (1 - row) & "]C:R[-1]C)"
' ActiveCell.FormulaR1C1 = "=AVERAGE(R[-59]C:R[-1]C)"
Application.Worksheets(table).Range(c & (row + 1)).Clear
Application.Worksheets(table).Range(c & (row + 1)).FormulaR1C1 = sss
Selection.NumberFormatLocal = "0.00_ "
End Function
'计算及格率并填入表格
Function setPassing(table As String, ByVal i As String, row As Integer) As Integer
c = Chr(i + Asc("A") - 1)
Range(c & (row + 1)).Select
sss = "=COUNTIF(R[" & (1 - row) & "]C:R[-2]C,"">=60"")/COUNT(R[" & (1 - row) & "]C:R[-2]C)"
Application.Worksheets(table).Range(c & (row + 1)).Clear
Selection.NumberFormatLocal = "0.000_ "
Application.Worksheets(table).Range(c & (row + 1)).FormulaR1C1 = sss
End Function
'
'计算优秀率并填入表格
Function setExcellent(table As String, ByVal i As String, row As Integer) As Integer
c = Chr(i + Asc("A") - 1)
Range(c & (row + 1)).Select
sss = "=COUNTIF(R[" & (1 - row) & "]C:R[-3]C,"">=80"")/COUNT(R[" & (1 - row) & "]C:R[-3]C)"
' ActiveCell.FormulaR1C1 = "=AVERAGE(R[-59]C:R[-1]C)"
Application.Worksheets(table).Range(c & (row + 1)).Clear
Selection.NumberFormatLocal = "0.000_ "
Application.Worksheets(table).Range(c & (row + 1)).FormulaR1C1 = sss
End Function
'完成查询功能并新建工作表保存,sql为查询语句
Sub sqlExe(sql As String, table As String)
Dim cnn As Object, rs As Object
Set cnn = CreateObject("adodb.connection") '创建数据库连接
cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ActiveWorkbook.FullName
Set rs = CreateObject("adodb.recordset") '创建一个数据集
Set rs = cnn.Execute(sql) '执行查询
Sheets.Add.name = table
ActiveWorkbook.Worksheets(table).Cells.ClearContents
Dim i As Integer
For i = 1 To rs.Fields.Count - 1
ActiveWorkbook.Worksheets(table).Cells(1, i) = rs.Fields(i - 1).name '填写标题到指定表
Next
ActiveWorkbook.Worksheets(table).Range("a2").CopyFromRecordset rs '复制记录集到指定表
rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing
End Sub
vba处理excel数据(学生成绩自动分班统计)
最新推荐文章于 2024-11-08 17:40:42 发布