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

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

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

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

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