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
|