Find Criteria, Delete rows above and below

Hi Ada01

I put together this code - crude I know but it seems to work

Sub Delete_Rows_Based_On_Criteria()

Dim newUpRow, newDownRow As Integer

Range("A1").Select
    Cells.Find(What:="Brown", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    
    newUpRow = ActiveCell.Row - 3
    Rows(newUpRow).Delete shift:=xlUp
    
    newDownRow = ActiveCell.Row + 4
    Rows(newDownRow).Delete shift:=xlUp

End Sub

Ada01,

I looked at your example. Did not realise that there would be many blank cells between each "Brown".

What do you want to do exactly? Delete the third row above and fourth row below Brown OR delete all three rows above and four rows below Brown?

The code I posted finds the first instance of "Brown" and then deletes the row three above that row and four rows below that.

Not sure what you mean by "not coming close"

Regards

Ada01,

I've looked again and the code below does the following:

Starts at A1 and looks for "Brown Printing Company" and when it finds it, selects from 3 rows above to 4 rows below and deletes them. It carries on until it returns to A1 again at which point the Sub ends.

Is that more what you were after?

Sub Delete_Rows_Based_On_Criteria()
Dim newUpRow, newDownRow As Integer
Range("A1").Select
    Cells.Find(What:="Brown Printing Company", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
Do While ActiveCell.Address <> "$A$1"
Do_Delete
    Cells.FindNext(After:=ActiveCell).Activate
Loop
End Sub

Function Do_Delete()
    newUpRow = ActiveCell.Row - 3
    newDownRow = ActiveCell.Row + 4
    Rows(newUpRow & ":" & newDownRow).Select
    Rows(newUpRow & ":" & newDownRow).Delete shift:=xlUp
End Function

Regards

You're welcome