Hi,

See if this helps. Try it in a copy of your workbook since changes cannot be undone.

Thanks

Sub DeleteRows()

Dim sh As Worksheet
Dim lrow As Long
Dim i As Long

Application.ScreenUpdating = False

'go through all the worksheets
For Each sh In ThisWorkbook.Worksheets

    'find the last row with data
    lrow = sh.Cells(Rows.Count, "D").End(xlUp).Row
    
    'go through the cells and check the name
    For i = lrow To 2 Step -1
        If Not sh.Cells(i, "D").Value = sh.Name Then
            sh.Cells(i, "D").EntireRow.Delete
        End If
    Next i
        
    'clear the formats in the cells
    sh.Cells.ClearFormats
Next sh
  
Application.ScreenUpdating = True

End Sub