Find keyword and delete the rows below and above

my request was changed as in 7th post
first part:
firts I want to find a specific word and the delete the rows above the row including found keyword.
In the sample find "there is no guarentee" then delete the rows (row numbers:4-3-2-1) (there is "there is no guarentee" 2 TIMES BUT THE FIRST ONE)

second part

I want to find a specific word and the delete the rows BELOW the row including found keyword.
In the sample find "ringtone to your cell" then delete the rows (row numbers:35-36-37...)) (there is "ringtone to your cell" 2 TIMES BUT THE LAST ONE)

This macro should work for all sheet in workbook.

before.xlsx
after.xlsx

ther'is only one row with the selected keyword in one sheet ?

I'm finding "ringtone to your cell" 2 times in each sheet, you marked in red only the second

Hi, patel45,

are you playing games with the TO?

ther'is only one row with the selected keyword in one sheet ?

I'm finding "ringtone to your cell" 2 times in each sheet, you marked in red only the second

Can´t find any code or hint for a solution in your answers in this thread so far.

Ciao,
Holger

Hi, zeroist,

I used two codes in my attempt to solve your problem. The first features the items you will search for as well as the number of rows to delete above and/or below the found item and a boolean to decide whether to delete or "paint" the area (we could add another parameter for the colour but I choose yellow here).

Sub EF953570()
'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("ringtone to your cell", 1, 1, False)    'will color all cells
Call SearchItemsInWorkbook("there is no guarentee", 2, 0, True)     'will delete all cells
End Sub

The second will loop through all worksheets and do accordingly:

Sub SearchItemsInWorkbook(strSearch As String, lngOffNeg As Long, lngOffPos As Long, blnDelete As Boolean)
' 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!

Dim wsTab As Worksheet
Dim rngCell As Range
Dim rngDelete As Range
Dim strAddress As String

For Each wsTab In ActiveWorkbook.Worksheets
  Set rngCell = wsTab.Cells.Find(what:=strSearch, lookAt:=xlPart)
  If Not rngCell Is Nothing Then
    strAddress = rngCell.Address
    Do
      If rngDelete Is Nothing Then
        Set rngDelete = rngCell.Offset(-lngOffNeg, 0).Resize(lngOffNeg + 1)
        Set rngDelete = Union(rngDelete, rngCell.Offset(lngOffPos, 0))
      Else
        Set rngDelete = Union(rngDelete, rngCell.Offset(-lngOffNeg, 0).Resize(lngOffNeg + 1))
        Set rngDelete = Union(rngDelete, rngCell.Offset(lngOffPos, 0))
      End If
      Set rngCell = wsTab.Cells.FindNext(After:=rngCell)
    Loop While rngCell.Address <> strAddress
  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

Ciao,
Holger

Thank you HaHoBe.
I am really sorry.you are right there is " ringtone to your cell " 2 times.ok.let me change the statu.

firts I want to find a specific word(there might be more than one.The answer of which one to choose is (the indicator) the FIrst OR the LAST ONE IN THE ROW)
first part:
firts I want to find a specific word and the delete the rows above the row including found keyword.
In the sample find "there is no guarentee" then delete the rows (row numbers:4-3-2-1) (there is "there is no guarentee" 2 TIMES BUT THE FIRST ONE)

second part

I want to find a specific word and the delete the rows BELOW the row including found keyword.
In the sample find "ringtone to your cell" then delete the rows (row numbers:35-36-37...)) (there is "ringtone to your cell" 2 TIMES BUT THE LAST ONE)

This macro should work for all sheet in workbook.

before.xlsx
after.xlsx

Hi, zeroist,

maybe your description is good for you to understand but I´m having problems understanding why in the After workbook Row 12 still shows the item which should have been deleted according to your requirements as I understand them. Before investing more time I would like you to clarify on that and assure that no further change in requirements will come.

A word an ASAP: everybody here in the forum is helping out for free, so any help available can only come if time is on hand for the preson who wants to help and if the problem is laid down clear to understand. If you really are in need of a solution you should consider to use the Commercial Services here but I´m afraid even there you would need to clarify what I asked above (I can assure you that I won´t take care of your thread over there if you decide to do so).

Ciao,
Holger

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

Hi, zeroist,

could you be a bit more specific about what I might have missed than just to state something without saying exactly what? When I tested the code on a copied sheet from your Before-workbook the code did exactly what I understood it should do.

You would need to start with EF953570_3 and maybe adjust the parameters which are passed due to the explanation (I entered them from what I read in your latest posts as well what I saw in the demo).

Ciao,
Holger

Hi, zeroist,

although I separated the two procedures when posting here they should be included into either one or 2 standard modules in the very same workbook for the ease of use (I had my versions of the code in the same modules).

Ciao,
Holger

Hi, zeroist,

maybe the best idea that you have missed up till now: make a copy of one sheet, mark the items to find and not to delete in one color (only the characters, say blue), the ones to delete in a different one (characters, red) and the areas to delete in a third colour (range/cells in yellow) and upload that workbook. Then maybe it will be clear to me what is wrong with what I coded from what I understood from your posts.

Ciao,
Holger

Hi, zeroist,

due to constellation you will have to search for ringtone to your cell first as on the start there are 2 occurrances but afterwards there is only one as the first one will have been deleted by the first occurrance of there is no guarentee.

Sub EF953570_4()
'will call procedure and hand over item to search, delete either the first ccurrance and every row including Found above (1)
'or last Found and below (2)
Call SearchItemsInWorkbook("ringtone to your cell", 2)
Call SearchItemsInWorkbook("there is no guarentee", 1)
End Sub

Sub SearchItemsInWorkbook(strSearch As String, lngFirst As Long)
' strSearch: item to search for as part of the cells
' lngFirst:  1 deletes the first occurrance of the item and all cells above
'            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 < 1 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
    If lngFirst = 1 Then
      Set rngDelete = Union(rngDelete, wsTab.Cells(1, 1).Resize(rngCell.Row))
    Else
      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)
        Else
          blnLoopOn = False
        End If
      Loop
    End If
  End If
  If lngFirst = 2 Then
    If Len(strTempAdr) > 0 Then
      Set rngDelete = wsTab.Range(wsTab.Range(strTempAdr), wsTab.Range("A" & Rows.Count).End(xlUp))
    Else
      Set rngDelete = wsTab.Range(rngDelete, wsTab.Range("A" & Rows.Count).End(xlUp))
    End If
  End If
  If Not rngDelete Is Nothing Then
    rngDelete.EntireRow.Delete
  End If
  Set rngDelete = Nothing
Next wsTab

Set rngCell = Nothing

End Sub

Ciao,
Holger

Hi, zeroist,

if the keywords aren´t found on the sheet that´s the normal way with teh code as it was supplied. Just change the position of the If-Statement that raisees the error, and the code will run through nicely (well, at least not raising any errors on testing):

The calling procedure will remain unchanged and just get a higher version number

Sub EF953570_4a()
'will call procedure and hand over item to search, delete either the first ccurrance and every row including Found above (1)
'or last Found and below (2)
Call SearchItemsInWorkbook("ringtone to your cell", 2)
Call SearchItemsInWorkbook("there is no guarentee", 1)
End Sub

Sub SearchItemsInWorkbook(strSearch As String, lngFirst As Long)
' strSearch: item to search for as part of the cells
' lngFirst:  1 deletes the first occurrance of the item and all cells above
'            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 < 1 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
    If lngFirst = 1 Then
      Set rngDelete = Union(rngDelete, wsTab.Cells(1, 1).Resize(rngCell.Row))
    Else
      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)
        Else
          blnLoopOn = False
        End If
      Loop
    End If
    If lngFirst = 2 Then
      If Len(strTempAdr) > 0 Then
        Set rngDelete = wsTab.Range(wsTab.Range(strTempAdr), wsTab.Range("A" & Rows.Count).End(xlUp))
      Else
        Set rngDelete = wsTab.Range(rngDelete, wsTab.Range("A" & Rows.Count).End(xlUp))
      End If
    End If
  End If
  If Not rngDelete Is Nothing Then
    rngDelete.EntireRow.Delete
  End If
  Set rngDelete = Nothing
Next wsTab

Set rngCell = Nothing

End Sub

Ciao,
Holger

Hi, zeroist,

I know you are getting angry with me,but one more help,

I prefer to answer to threads where the original request remains the same throughout as the concept was developed on hte first post (which is reverted withthe last request).

This is the code for the whole module in one code block:

Option Explicit

Dim mblnDelete As Boolean


Sub EF953570_5()
'will call procedure and hand over item to search, delete either the first ccurrance and every row including Found above (1)
'or last Found and below (2)
Dim wsTab As Worksheet

For Each wsTab In Worksheets
  mblnDelete = False
  Call SearchItemsInWorkbook(wsTab.Name, "ringtone to your cell", 2)
  Call SearchItemsInWorkbook(wsTab.Name, "there is no guarentee", 1)
  If mblnDelete Then
    Application.DisplayAlerts = False
    wsTab.Delete
    Application.DisplayAlerts = True
  End If
Next wsTab


End Sub
Sub SearchItemsInWorkbook(strSheet As String, strSearch As String, lngFirst As Long)
' strSearch: item to search for as part of the cells
' lngFirst:  1 deletes the first occurrance of the item and all cells above
'            2 deletes the last occurrance of the item

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

If lngFirst < 1 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

Set wsWork = Sheets(strSheet)
blnLoopOn = True
Set rngCell = wsWork.Cells.Find(what:=strSearch, lookAt:=xlPart)
If Not rngCell Is Nothing Then
  Set rngDelete = rngCell
  If lngFirst = 1 Then
    Set rngDelete = Union(rngDelete, wsWork.Cells(1, 1).Resize(rngCell.Row))
  Else
    strAddress = rngCell.Address
    Do While blnLoopOn
      Set rngCell = wsWork.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)
      Else
        blnLoopOn = False
      End If
    Loop
  End If
  If lngFirst = 2 Then
    If Len(strTempAdr) > 0 Then
      Set rngDelete = wsWork.Range(wsWork.Range(strTempAdr), wsWork.Range("A" & Rows.Count).End(xlUp))
    Else
      Set rngDelete = wsWork.Range(rngDelete, wsWork.Range("A" & Rows.Count).End(xlUp))
    End If
  End If
Else
  mblnDelete = True
End If
If Not rngDelete Is Nothing Then
  rngDelete.EntireRow.Delete
End If
Set rngDelete = Nothing

Set rngCell = Nothing

Set wsWork = Nothing

End Sub

Ciao,
Holger