vba处理excel数据（学生成绩自动分班统计）

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