Inserting Mulitple Criteria
It still deletes everything. Thanks very much for your help. I was able to
obtain code to do what I needed just in a different way. I now delete any row
where the cell in column "E" contains alpha characters.
Sub DeleteNonNumericRows()
LastRow = Range("E" & Rows.Count).End(xlUp).Row
For r = LastRow To 4 Step -1
If Not IsNumeric(Cells(r, "E")) Then
Rows(r).Delete
End If
Next
End Sub
"Jacob Skaria" wrote:
Try this
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
Exit For
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:
It seems to work with one piece of criteria but if there are 2 or more it
deletes everything.
"Jacob Skaria" wrote:
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
|