Find a student's 3 lowest scoring tests

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