提取2010年5月份补考名单(以理科为例）

这次的任务比较简单，就是把理科各科后60名的学生提出来。不再多说，直接上图：

这是处理前的样式。在处理前，遵从错误可以挽回的原则，应该在处理前先做一个备份，或者说创建一个副本以便于处理。源程序如下：

Option Base 1
Sub 提取补考学生名单理科各科后60名()
    Dim fs(6) As Double, i As Integer, totalR As Integer, mycell As Range
    Worksheets("sheet1").Activate
    ActiveSheet.Copy before:=Sheets(1)
    ActiveSheet.Name = "补考名单"
    totalR = Range("A65536").End(xlUp).Row
    '按各科所在列进行标志，将需要补考的科目标志为红色，不需要补考的的成绩标志为“否”
    For i = 1 To 6
        fs(i) = Application.WorksheetFunction.Small(Range(Cells(2, i + 3), Cells(totalR, i + 3)), 60)
        Debug.Print fs(i)
        For Each mycell In Range(Cells(2, i + 3), Cells(totalR, i + 3))
            If mycell.Value <= fs(i) Then
                mycell.Font.ColorIndex = 3
            End If
            If mycell.Font.ColorIndex <> 3 Then
                mycell.Value = "否"
            End If
        Next mycell
    Next i
    '从最后一行开始起删除全为“否”的列，因为此生一定不需要补考。
    For i = totalR To 1 Step -1 '若从第一行开始,一旦出现了删除结果,会导致行数不对.易出现漏删现象.
        If Application.WorksheetFunction.CountIf(Range(Cells(i, 4), Cells(i, 9)), "否") = 6 Then '因为共6科，故统计全为“否“的是否为6即可。
            Range(Cells(i, 1), Cells(i, 1)).EntireRow.Delete
        End If
    Next i
    '再遍历所有科目所在单元格，将某学生不需要参加补考的科目（已经标志为“否”），清空，便于核对。
    For Each mycell In Range(Cells(2, 4), Cells(totalR, 9))
        If mycell.Value = "否" Then
            mycell.ClearContents
        End If
    Next mycell
End Sub

得到的最终效果如下图所示：

嘿嘿，虽然麻烦点，但个人以为不管麻烦也好，简单也好，不都是想把活干好吗？不都是为了尽可能减轻自己的工作量吗？所以虽然程序不大好看，但实用就可以，而且写程序最重要的一条就是不能出错。如果出错那就说明是失败的！！

 今天你菊子曰了么？