Highlight Cell If

[Guest]

I need a macro that will hightlight the cell if it contains a certain number
anywhere in the cell. This number can be located in the back or the front
of the entire text string and can be 4, 5, or 6 characters long

My current macro only highlights the cell if the numbers are found from left
to right

I started to write macro for this but it is getting too big. I need to add
15 more numbers to this macro, but wanted to see if there was a better way of
doing this. Can anyone help me with my macro to make it more efficient?

Sub Color_Cells()

Application.ScreenUpdating = False
Dim i As Long
i = 7
Application.ScreenUpdating = False
Do Until IsEmpty(Cells(i, 2))
If LCase(Left(Cells(i, 3).Value, 6)) = LCase("510026") Or _
LCase(Left(Cells(i, 3).Value, 6)) = LCase("510054") Or _
LCase(Left(Cells(i, 3).Value, 5)) = LCase("93003") Or _
LCase(Left(Cells(i, 3).Value, 2)) = LCase("93") Or _
LCase(Left(Cells(i, 3).Value, 7)) = LCase("5721358") Or _
LCase(Left(Cells(i, 3).Value, 8)) = LCase("51002649") Or _
LCase(Left(Cells(i, 3).Value, 11)) = LCase("55655555556") Or _
LCase(Left(Cells(i, 3).Value, 6)) = LCase("510789") Then
Cells(i, 4).Interior.ColorIndex = 36
End If
i = i + 1
Loop

End Sub

 

[Guest]

try:

Sub Color_Cells()

' expand as required
FindArray = Array("510026", "510054", "93003", "93", "5721358", "51002649",
"55655555556", "510789")

Application.ScreenUpdating = False
Dim i As Long
i = 7
Application.ScreenUpdating = False
Do Until IsEmpty(Cells(i, 2))
For j = LBound(FindArray) To UBound(FindArray)
If InStr(1, Cells(i, 2), FindArray(j)) Then
Cells(i, 4).Interior.ColorIndex = 36
Exit For
End If
Next j
i = i + 1
Loop

End Sub

 

[Guest]

It works great!!!!!!!

THANKS!!!!

try:

Sub Color_Cells()

' expand as required
FindArray = Array("510026", "510054", "93003", "93", "5721358", "51002649",
"55655555556", "510789")

Application.ScreenUpdating = False
Dim i As Long
i = 7
Application.ScreenUpdating = False
Do Until IsEmpty(Cells(i, 2))
For j = LBound(FindArray) To UBound(FindArray)
If InStr(1, Cells(i, 2), FindArray(j)) Then
Cells(i, 4).Interior.ColorIndex = 36
Exit For
End If
Next j
i = i + 1
Loop

End Sub