Sub Marine()

' deletes all but criteria

Dim Criteria As String
Criteria = "Y08" 'Change to suit"
mycolumn = "E" 'Change to suit
Dim MyRange, MyRange1 As Range
LastRow = Cells(Rows.Count, mycolumn).End(xlUp).Row
Set MyRange = Range(mycolumn & "4:" & mycolumn & LastRow)
For Each C In MyRange
Select Case C
Case "Y09","Y08",777
If MyRange1 Is Nothing Then
Set MyRange1 = C.EntireRow
Else
Set MyRange1 = Union(MyRange1, C.EntireRow)
End If
End Select
Next
If Not MyRange1 Is Nothing Then
MyRange1.Delete
End If
End Sub

"Peruanos72" wrote:

Hello again,

I was given the following code and it works however I need make some minor
changes.

For Sub marine() I need to enter more than one criteria
Ex: Criteria = "Y09" and "Y08" and "777"

I need to run the code for alphanumeric as well as numeric. Thoughts?

Sub Marine()

' deletes all but criteria

Dim Criteria As String
Criteria = "Y08" 'Change to suit"
mycolumn = "E" 'Change to suit
Dim MyRange, MyRange1 As Range
LastRow = Cells(Rows.Count, mycolumn).End(xlUp).Row
Set MyRange = Range(mycolumn & "4:" & mycolumn & LastRow)
For Each C In MyRange
If InStr(1, C.Value, Criteria, 1) < 1 Then
If MyRange1 Is Nothing Then
Set MyRange1 = C.EntireRow
Else
Set MyRange1 = Union(MyRange1, C.EntireRow)
End If
End If
Next
If Not MyRange1 Is Nothing Then
MyRange1.Delete
End If
End Sub