Need help connecting multiple data rows to one name

Amended code:

Sub Fill_Grade_Sheets()

Dim ws1 As Worksheet
Dim ws2 As Worksheet

Dim r As Long
Dim rr As Long
Dim ns As Long

Dim Student As String


Set ws1 = Worksheets("Grades")
Set ws2 = Worksheets("Grade Sheets")

r = 2
rr = 4
ns = 1

ws1.Activate

With ws1

Do While .Cells(r, 1) <> ""

    ' Fiil in a Grade sheet
    '
    rs = (ns - 1) * 25
    Student = .Cells(r, 3)
    
    ws2.Cells(rs + 4, 1) = .Cells(r, 3)
    ws2.Cells(rs + 4, 4) = .Cells(r, 1)
    ws2.Cells(rs + 4, 9) = .Cells(r, 8)
    
    Do While .Cells(r, 3) = Student
    
        ws2.Cells(rs + 7, 2) = .Cells(r, 4)
        ws2.Cells(rs + 8, 2) = .Cells(r, 5)
        ws2.Cells(rs + 9, 2) = .Cells(r, 6)
        
        r = r + 1
        rs = rs + 5
    
    Loop
    
    ns = ns + 1

Loop

End With

ws2.Activate

End Sub