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
Bookmarks