Inserting Mulitple Criteria
 

Please try and feedback

Sub Marine()

' deletes all but criteria

Dim arrCriteria As Variant
Dim intCriteria As Integer
Dim MyRange, MyRange1 As Range

arrCriteria = Array("Y08", "Y09", "Y07") 'Change to suit"
mycolumn = "E" 'Change to suit
LastRow = Cells(Rows.Count, mycolumn).End(xlUp).Row
Set MyRange = Range(mycolumn & "4:" & mycolumn & LastRow)
For Each C In MyRange
For intCriteria = 0 To UBound(arrCriteria)
If InStr(1, C.Value, arrCriteria(intCriteria), 1) < 1 Then
If MyRange1 Is Nothing Then
Set MyRange1 = C.EntireRow
Else
Set MyRange1 = Union(MyRange1, C.EntireRow)
End If
End If
Next
Next
If Not MyRange1 Is Nothing Then
MyRange1.Delete
End If
End Sub

--
If this post helps click Yes
---------------
Jacob Skaria


"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