如何根据学生各科及总分成绩划分等第

问题提出的背景：现在实行素质教育后，不允许给学生公布成绩了，只允许以A、B、C、D的形式进行公布，以前都是在VFP中进行，但需要来回的转换格式，很是烦锁，尤其是在转换时，需要一科科的进行数据格式的转换还往往出问题，如果在Excel里就可以直接转换的话，那肯定可以节省很多时间。

问题解决的思路：因为只能有A、B、C、D四个等第，所以可以利用Select Case语句来解决，而且以前最熟悉的是IF语句，现在想知彻底解决条件判断语句的用法。就以这个作为一个例子吧。

首先根据成绩及A、B、C、D四个等第的比例进行等第确认，源程序如下：

Sub 等第确认()
    '打开zcj工作表
    Dim mycell As Range
    Worksheets("zcj").Activate
    For i = 1 To 3
        For Each mycell In Range(Cells(2, 6 + (i - 1) * 3), Cells(1172, 6 + (i - 1) * 3))
            Select Case mycell.Value
                Case 1052 To 1171
                    mycell.Offset(0, 1).Value = "D"
                Case 1051 * 0.7 To 1051
                    mycell.Offset(0, 1).Value = "C"
                Case 1051 * 0.3 To 1051 * 0.7
                    mycell.Offset(0, 1).Value = "B"
                Case Else
                    mycell.Offset(0, 1).Value = "A"
            End Select
        Next mycell
    Next i
    ActiveSheet.Copy before:=ActiveSheet
    ActiveSheet.Name = "zcj备份"
    Worksheets("zcj").Activate
    '以下为把所有等第为A、B、C的学生完全删掉，这样只留下等第为D的学生了。
    Dim totalR As Integer
    totalR = Range("C65536").End(xlUp).Row
    For i = totalR To 2 Step -1
        If Application.WorksheetFunction.CountIf(Range(Cells(i, 5), Cells(i, 13)), "D") = 0 Then
            Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
        End If
    Next i
    Range("A1").CurrentRegion.Font.Name = "微软雅黑"
    Range("A1").CurrentRegion.Font.Size = 10
End Sub

效果截图如下：

图1 确认完等第后的效果图

图2 把没有D的学生删掉后的效果图

另一方法，源程序如下：

Sub 提取等第为D学生名单()
    Dim totalRD As Integer
    Dim totalR, i As Integer
    Dim mycell As Range
    totalRD = 1
    Worksheets("等第为D学生名单").Activate
    Worksheets("语数外等第公示").Activate
    totalR = Range("C65536").End(xlUp).Row
    For Each mycell In Range("E2:H1172")
        If mycell = "D" Then
            mycell.EntireRow.Copy
            Worksheets("等第为D学生名单").Activate
            totalRD = Range("C65536").End(xlUp).Row
            Range(Cells(totalRD + 1, 1), Cells(totalRD + 1, 1)).PasteSpecial xlPasteAll
            Application.CutCopyMode = False
            Worksheets("语数外等第公示").Activate
        End If
    Next mycell
    '删掉重复值
    Worksheets("等第为D学生名单").Activate
    totalRD = Range("C65536").End(xlUp).Row
    For i = totalRD To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range(Cells(1, 2), Cells(totalRD, 2)), Cells(i, 2)) > 1 Then
            Range(Cells(i, 2), Cells(i, 2)).EntireRow.Delete
        End If
    Next i
    Range("A1").CurrentRegion.Font.Name = "微软雅黑"
    Range("A1").CurrentRegion.Font.Size = 10
End Sub

对比：第2种方法也可以，但显得太麻烦，因为需要做多个工作表，而且会在“等第为D学生名单”中出现多个重复值，不利于数据的严谨性，所以还是第1种方法较科学。

 今天你菊子曰了么？