Find keyword and delete the rows below and above

Hi, zeroist,

maybe this code will perform as you wish:

Sub SearchItemsInWorkbook(strSearch As String, lngOffNeg As Long, lngOffPos As Long, blnDelete As Boolean, lngFirst As Long)
' strSearch: item to search for as part of teh cells
' lngOffNeg: number of rows above the found cell to be deleted, should be entered as positiv number!
' lngOffPos: number of rows below the found cell to be deleted, should be entered as positiv number!
' blnDelete: deicdes on TRUE to delete or FALSE to color
' lngFirst:  0 deletes any occurrance of the item
'            1 deletes the first occurrance of the item
'            2 deletes the last occurrance of the item

Dim wsTab As Worksheet
Dim rngCell As Range
Dim rngDelete As Range
Dim strAddress As String
Dim strTempAdr As String
Dim blnLoopOn As Boolean
Dim blnFirst As Boolean

If lngFirst < 0 And lngFirst > 2 Then
  MsgBox "Value for parameter of what to delete is out of range available (must be 0 for all, 1 for first, 2 for last)!"
  Exit Sub
End If

For Each wsTab In ActiveWorkbook.Worksheets
  blnLoopOn = True
  Set rngCell = wsTab.Cells.Find(what:=strSearch, lookAt:=xlPart)
  If Not rngCell Is Nothing Then
    Set rngDelete = rngCell
    Set rngDelete = Union(rngDelete, rngCell.Offset(-lngOffNeg, 0).Resize(lngOffNeg + 1))
    Set rngDelete = Union(rngDelete, rngCell.Resize(lngOffPos + 1))
    Select Case lngFirst
      Case 0, 2
        strAddress = rngCell.Address
        Do While blnLoopOn
          Set rngCell = wsTab.Cells.FindNext(After:=rngCell)
          blnLoopOn = rngCell.Address <> strAddress
          If Not rngCell Is Nothing And rngCell.Address <> strAddress Then
            strTempAdr = rngCell.Address
            Set rngDelete = Union(rngDelete, rngCell.Offset(-lngOffNeg, 0).Resize(lngOffNeg + 1))
            Set rngDelete = Union(rngDelete, rngCell.Resize(lngOffPos + 1))
          Else
            blnLoopOn = False
          End If
        Loop
      Case Else
    End Select
  End If
  If lngFirst = 2 Then
    If Len(strTempAdr) > 0 Then
      Set rngDelete = wsTab.Range(strTempAdr)
      Set rngDelete = Union(rngDelete, rngCell.Offset(-lngOffNeg, 0).Resize(lngOffNeg + 1))
      Set rngDelete = Union(rngDelete, rngCell.Resize(lngOffPos + 1))
    End If
  End If
  If Not rngDelete Is Nothing Then
    If blnDelete Then
      rngDelete.EntireRow.Delete
    Else
      rngDelete.Interior.ColorIndex = 6
    End If
  End If
  Set rngDelete = Nothing
Next wsTab

Set rngCell = Nothing

End Sub

Sub EF953570_3()
'will call procedure and hand over item to serach, the number of rows above (eneterd asp positive number) as
'well as number of rows below found to delete and advise to delete or just color
Call SearchItemsInWorkbook("there is no guarentee", 3, 0, True, 1)
Call SearchItemsInWorkbook("ringtone to your cell", 0, 3, True, 2)
End Sub

Ciao,
Holger