Find a student's 3 lowest scoring tests

Hello VBA pro's,

I have attached a workbook that shows what I would like to do.

I am a teacher and use excel as my grade book. The grade book will contain 30 to 40 tests (I only did 10ish on the example worksheet) in columns with student names in the corresponding rows. I would like to write a VBA subroutine that scans each student's scores (in the rows) and then reports to me what their 3 lowest tests are (not the scores themselves but the testnames). These testnames will then be returned to a separate range like the one in the middle of the sheet.


Thank you in advanced for your help.

Steve_G_2,

The code I came up with works and returns the desired results, but I wouldn't exactly call it efficient. I just couldn't come up with a better way to do it. Here's the code:

Sub LowestScores()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Dim NameResultCol As String:    NameResultCol = "E"
    Dim NameResultRow As Long:      NameResultRow = 13
    Dim rngStudents As Range:       Set rngStudents = ActiveSheet.Range(Cells(2, 1).Address & ":" & Cells(Rows.Count, 1).End(xlUp).Address)
    Dim TestNameRow As Long:        TestNameRow = 1
    
    Dim Test1 As Long, Test2 As Long, Test3 As Long
    Dim Test1Name As String, Test2Name As String, Test3Name As String
    Dim sCell As Range, rCell As Range, LastTest As Long, CheckTest As Long
    For Each rCell In rngStudents
        LastTest = ActiveSheet.Cells(rCell.Row, Columns.Count).End(xlToLeft).Column
        Test1 = 1000000
        Test2 = 1000000
        Test3 = 1000000
        
        CheckTest = rngStudents.Column + 1
        While CheckTest <= LastTest
            If ActiveSheet.Cells(rCell.Row, CheckTest).Value < Test1 Then
                
                Test1 = ActiveSheet.Cells(rCell.Row, CheckTest).Value
                Test1Name = ActiveSheet.Cells(TestNameRow, CheckTest).Value
            
            End If
            CheckTest = CheckTest + 1
        Wend
        
        CheckTest = rngStudents.Column + 1
        While CheckTest <= LastTest
            If ActiveSheet.Cells(rCell.Row, CheckTest).Value <= Test2 And _
                ActiveSheet.Cells(TestNameRow, CheckTest).Value <> Test1Name Then
                
                Test2 = ActiveSheet.Cells(rCell.Row, CheckTest).Value
                Test2Name = ActiveSheet.Cells(TestNameRow, CheckTest).Value
                   
            End If
            CheckTest = CheckTest + 1
        Wend
        
        CheckTest = rngStudents.Column + 1
        While CheckTest <= LastTest
            If ActiveSheet.Cells(rCell.Row, CheckTest).Value <= Test3 And _
                ActiveSheet.Cells(TestNameRow, CheckTest).Value <> Test1Name And _
                ActiveSheet.Cells(TestNameRow, CheckTest).Value <> Test2Name Then
                
                Test3 = ActiveSheet.Cells(rCell.Row, CheckTest).Value
                Test3Name = ActiveSheet.Cells(TestNameRow, CheckTest).Value
                
            End If
            CheckTest = CheckTest + 1
        Wend
        
        ActiveSheet.Range(NameResultCol & NameResultRow).Offset(0, 1).Value = Test1Name
        ActiveSheet.Range(NameResultCol & NameResultRow).Offset(0, 2).Value = Test2Name
        ActiveSheet.Range(NameResultCol & NameResultRow).Offset(0, 3).Value = Test3Name
        
        NameResultRow = NameResultRow + 1
        
    Next rCell
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
End Sub

Notes:
If, on your real spreadsheet, the following are different, just change the code to the correct values:

• NameResultCol (This is the column that contains "Bill's 3 Lowest" etc. In the sample you provided, it was column E)
• NameResultRow (This is the row that "Bill's 3 Lowest" etc. starts on. In the sample you provided, it was row 13)
• TestNameRow (This is the row that contains the tests' names. In the sample you provided, it was row 1)

I have attached a modified version of your workbook so you can see how it works

Hope that helps,
~tigeravatar

Hi,

Try this, run Macro FindLScores and check the result in Sheets("Result")

Tony

Thank you for the help. You are all fabulous.