variation of "delete all except"

[acarril]

i have some code someone from here was gracious enought to provide
while back. i am trying to create a variation to what i have. i woul
like it to delete all except each criteria but i also want to keep th
four rows immediately following each found exception. is thi
possible? thanks in advance for your help-here is the code:

Sub DeleteAllExcept()
Dim Exceptions As Variant
Dim cell As Range, LastCell As Range
Dim MyDelRng As Range
Dim WB As Workbook, SH As Worksheet
Dim CountryCol As String
Dim blKeep As Boolean

Exceptions = Array("RH - MONTH TOTAL:", "RO - MONTH TOTAL:", "SO
MONTH TOTAL:", "SH - MONTH TOTAL:")
Set WB = Workbooks("poreport-test.xls")
Set SH = WB.Sheets("poreport")
CountryCol = "A"

Set LastCell = SH.Cells(Rows.Count, CountryCol).End(xlUp)
For Each cell In Range(SH.Cells(1, CountryCol), LastCell)
blKeep = False
On Error Resume Next
blKeep = Application.Match(cell.Value, Exceptions, 0)
On Error Resume Next

If Not blKeep Then
If MyDelRng Is Nothing Then
Set MyDelRng = cell
Else
Set MyDelRng = Union(cell, MyDelRng)
End If
End If
Next cell

If Not MyDelRng Is Nothing Then
MyDelRng.EntireRow.Delete
Else
MsgBox "No data found to delete"
End If

End Su

 

[Dave Peterson]

Try this against a copy of your worksheet.

Option Explicit
Sub DeleteAllExcept()

Dim Exceptions As Variant
Dim MyDelRng As Range
Dim WB As Workbook, SH As Worksheet
Dim CountryCol As String
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long

Exceptions = Array("RH - MONTH TOTAL:", "RO - MONTH TOTAL:", _
"SO - MONTH TOTAL:", "SH - MONTH TOTAL:")

Set WB = Workbooks("poreport-test.xls")
Set SH = WB.Sheets("poreport")

'for testing
'Set SH = ActiveSheet

CountryCol = "A"

With SH

FirstRow = 1
LastRow = .Cells(.Rows.Count, CountryCol).End(xlUp).Row

iRow = 1
Do
If iRow > LastRow Then
Exit Do
End If

If IsError(Application.Match(.Cells(iRow, _
CountryCol).Value, Exceptions, 0)) Then
'not found
If MyDelRng Is Nothing Then
Set MyDelRng = .Cells(iRow, "A")
Else
Set MyDelRng = Union(.Cells(iRow, "A"), MyDelRng)
End If
iRow = iRow + 1
Else
'skip around this one and the next 4
iRow = iRow + 1 + 4
End If
Loop
End With

If Not MyDelRng Is Nothing Then
MyDelRng.EntireRow.Delete
Else
MsgBox "No data found to delete"
End If

End Sub