Inserting Mulitple Criteria
 

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

Inserting Mulitple Criteria
 

nothing seems to happen when i run the code. I was able to use other code
though
to delete the data in a different way. Thanks for your help.

"joel" wrote:

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

Inserting Mulitple Criteria
 

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

Inserting Mulitple Criteria
 

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

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