Excel Forum

Code: Select all

 Sub BellCurveGrading()
    Dim ws As Worksheet
    Dim scores As Range
    Dim sortedScores As Range
    Dim totalStudents As Long
    Dim i As Long
    Dim grade As String
    Dim lastGrade As String
    Dim currentScore As Double
    Dim nextScore As Double
    Dim gradeCount As Long
    
    ' ¡Ó˹´ Worksheet áÅЪèǧ¤Ðá¹¹
    Set ws = ThisWorkbook.Sheets("Data") ' à»ÅÕ蹪×èÍá¼è¹§Ò¹µÒÁµéͧ¡ÒÃ
    Set scores = ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
    
    ' ¤Ñ´ÅÍ¡áÅÐàÃÕ§ÅӴѺ¤Ðá¹¹
    scores.Sort Key1:=scores, Order1:=xlDescending
    
    totalStudents = scores.Count
    
    ' ¡Ó˹´à¡Ã´µÒÁ Bell Curve
    gradeCount = 0 ' µÑÇá»ÃÊÓËÃѺ¹Ñº¨Ó¹Ç¹¤Ðá¹¹·Õèã¡Åéà¤Õ§¡Ñ¹
    For i = 1 To totalStudents
        currentScore = ws.Cells(i + 1, 1).Value
        
        ' µÃǨÊͺ¤Ðá¹¹·Õè«éӡѹ
        If i < totalStudents Then
            nextScore = ws.Cells(i + 2, 1).Value
        Else
            nextScore = currentScore ' ËÒ¡à»ç¹¤Ðá¹¹ÊØ´·éÒÂ
        End If
        
        ' ¡Ó˹´à¡Ã´
        If i <= totalStudents * 0.05 Then
            grade = "5"
        ElseIf i <= totalStudents * 0.35 Then
            grade = "4"
        ElseIf i <= totalStudents * 0.75 Then
            grade = "3"
        ElseIf i <= totalStudents * 0.9 Then
            grade = "2"
        Else
            grade = "1"
        End If
        
        ' »Ñ´Å§àÁ×èͤÐá¹¹µèÓÊØ´«éÓ
        If nextScore = currentScore And grade = "1" Then
            grade = "1"
        End If
        
        ' »Ñ´¢Öé¹àÁ×èͤÐá¹¹ÊÙ§ÊØ´«éÓ
        If nextScore = currentScore And grade = "5" Then
            grade = "5"
        End If

        ws.Cells(i + 1, 2).Value = grade ' ãÊèà¡Ã´ã¹¤ÍÅÑÁ¹ì B
    Next i
    
    MsgBox "¡ÒõѴà¡Ã´àÊÃç¨ÊÔé¹", vbInformation
End Sub