Deleting rows with specific text

[gauca001]

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

[Logit]

.
This is one method :



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

[gauca001]

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.




.
This is one method :



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

[Logit]

.


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

[gauca001]

Hi Logit,

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

Thanks again.



.


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

[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.

[gauca001]

.
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.

[gauca001]

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

[rlv]

Another way to approach it, using autofilter



'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

[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.





Another way to approach it, using autofilter



'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

[rlv]

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.