Delete extra row

How about this:

Sub DeleteExtraRows()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dict As Object
    Dim i As Integer
    Dim personID As String
    
    Set ws = ThisWorkbook.Sheets("YourSheetName") ' Change to your actual sheet name
    Set dict = CreateObject("Scripting.Dictionary")
    
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row ' Assumes IDs are in column A
    
    For i = lastRow To 1 Step -1
        personID = ws.Cells(i, 1).Value
        If Not dict.exists(personID) Then
            dict.Add personID, 0
        End If
        
        dict(personID) = dict(personID) + 1
        
        If dict(personID) > 24 Then
            ws.Rows(i).Delete
        End If
    Next i
End Sub