Deleting rows with specific text

I am looking for VBA code that will delete rows not containing the word "profile" and those not containing the word "advanced". Besides I would like to keep blank rows that come every 9th row. (row 9, 18, 27 etc must be kept blank).

Thanks

.
This is one method :

Code:

---

Option Explicit


Sub RwDel()


Dim x As Long, trm As String, trm2 As String


trm = "profile"
trm2 = "advanced"


With Sheets("Sheet1")    '<~~~ edit Sheet as required
    For x = .Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
        If Not Rows(x).Find(trm) Is Nothing Or Not Rows(x).Find(trm2) Is Nothing Then Rows(x).Delete
    Next x
End With


End Sub

---

Hi Logit, Thanks for your reply. The code is deleting the rows with "advanced" and keeping the blank rows as required, but unfortunatelly it is also deleting the rows with the text "profile" which are needed.

Can you please amend to make it work as needed.


Thanks again.

Quote:

---

Originally Posted by Logit

.
This is one method :

Code:

---

Option Explicit


Sub RwDel()


Dim x As Long, trm As String, trm2 As String


trm = "profile"
trm2 = "advanced"


With Sheets("Sheet1")    '<~~~ edit Sheet as required
    For x = .Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
        If Not Rows(x).Find(trm) Is Nothing Or Not Rows(x).Find(trm2) Is Nothing Then Rows(x).Delete
    Next x
End With


End Sub

---

---

.

Code:

---

Sub RwDel2()




Dim x As Long, trm As String, trm2 As String




trm = "profile"




With Sheets("Sheet1")    '<~~~ edit Sheet as required
    For x = .Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
        If Not Rows(x).Find(trm2) Is Nothing Then Rows(x).Delete
    Next x
End With




End Sub

---

Hi Logit,

Thanks very much, this code worked for me although there was trm2 = "advanced" missing which I added myself.

Thanks again.

Quote:

---

Originally Posted by Logit

.

Code:

---

Sub RwDel2()




Dim x As Long, trm As String, trm2 As String




trm = "profile"




With Sheets("Sheet1")    '<~~~ edit Sheet as required
    For x = .Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
        If Not Rows(x).Find(trm2) Is Nothing Then Rows(x).Delete
    Next x
End With




End Sub

---

---

.
You are welcome. Apologies for the oversight. Im doing more of that lately. My old mind and eyes are not working together.

Need to locate the fountain of youth.

Quote:

---

Originally Posted by Logit

.
You are welcome. Apologies for the oversight. Im doing more of that lately. My old mind and eyes are not working together.

Need to locate the fountain of youth.

---

Hi Logit, it's me again, may I ask you one more favour. Can you please edit the code to do the opposite as I may need this scenario as well that is the code is to keep the rows with "profile" and "advanced" and the blank lines every 9th row and remove all the other rows

Another way to approach it, using autofilter

Code:

---

'Assumes the first row contains column labels
Sub KeepProfileAdvanced()
    Dim WS As Worksheet
    Dim FilterRange As Range
    Dim DataRange As Range
    Dim DeleteRange As Range
    Dim I As Long, LR As Long

    Set WS = ActiveSheet

    With WS
        Set FilterRange = .Range(.Range("A1"), .Cells(.Rows.Count, "A").End(xlUp))
        Set DataRange = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)

        If WS.AutoFilterMode Then
            WS.AutoFilterMode = False
        End If
    End With

    Application.ScreenUpdating = False
    FilterRange.AutoFilter Field:=1, Criteria1:="<>profile", Operator:=xlAnd, Criteria2:="<>advanced"
    Set DeleteRange = Application.Intersect(FilterRange.SpecialCells(xlCellTypeVisible).EntireRow, DataRange.EntireRow)

    If WS.AutoFilterMode Then
        WS.AutoFilterMode = False
    End If

    If Not DeleteRange Is Nothing Then
        DeleteRange.Delete                            'delete rows
        'Add blank lines
        With DataRange
            LR = .Rows.Count
            For I = 1 To LR
                If I Mod 9 = 0 Then
                    .Cells(I, 1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    LR = LR + 1
                End If
            Next I
        End With
    End If

    Application.ScreenUpdating = True
End Sub

---

Thanks for the code but this does not work for me as it almost deleted everything including the rows which I want to keep.

Quote:

---

Originally Posted by rlv

Another way to approach it, using autofilter

Code:

---

'Assumes the first row contains column labels
Sub KeepProfileAdvanced()
    Dim WS As Worksheet
    Dim FilterRange As Range
    Dim DataRange As Range
    Dim DeleteRange As Range
    Dim I As Long, LR As Long

    Set WS = ActiveSheet

    With WS
        Set FilterRange = .Range(.Range("A1"), .Cells(.Rows.Count, "A").End(xlUp))
        Set DataRange = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)

        If WS.AutoFilterMode Then
            WS.AutoFilterMode = False
        End If
    End With

    Application.ScreenUpdating = False
    FilterRange.AutoFilter Field:=1, Criteria1:="<>profile", Operator:=xlAnd, Criteria2:="<>advanced"
    Set DeleteRange = Application.Intersect(FilterRange.SpecialCells(xlCellTypeVisible).EntireRow, DataRange.EntireRow)

    If WS.AutoFilterMode Then
        WS.AutoFilterMode = False
    End If

    If Not DeleteRange Is Nothing Then
        DeleteRange.Delete                            'delete rows
        'Add blank lines
        With DataRange
            LR = .Rows.Count
            For I = 1 To LR
                If I Mod 9 = 0 Then
                    .Cells(I, 1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    LR = LR + 1
                End If
            Next I
        End With
    End If

    Application.ScreenUpdating = True
End Sub

---

---

Quote:

---

Originally Posted by gauca001

Thanks for the code but this does not work for me as it almost deleted everything including the rows which I want to keep.

---

Well it's an example, not a tailored solution.