Find partial match between two columns and highlight cells that match

So I have searched for a solution through several forums including this one and I am unable to find a proper one yet. Here's what I need to do.

I need to search all of the contents of Sheet1 ColumnJ and see if there is a partial match with any cell of Sheet2 Column A. I want to have every cell that is partially matched to be shaded in red and every cell with no match to be shaded blue. Sounds simple and I have tried different methods to no avail.

Heres what the cells in Sheet1 ColumnJ might look like:
001127-1-1 / 0 / 110(S)
001028-5-1 / 0 / 10(S)
001116-1-1 / 0 / 130(S)
001095-1-1 / 0 / 110(S)
001145-1-1 / 0 / 110(S)
001105-1-1 / 0 / 120(S)

And Sheet2 Column A Might Be:
1148
1145
1116
1140
1105
1135
1127
1132
1129

So if run properly, the following cells would be shaded Red
001127-1-1 / 0 / 110(S)
001116-1-1 / 0 / 130(S)
001105-1-1 / 0 / 120(S)

and the rest would be blue.

Agreed with Pauleyb, i think 1145 should be red too, based on your description. If so, try this code:

Sub TomToms()

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

Set CheckRange = ws2.Range("A1:A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row)
Set SearchRange = ws1.Range("J1:J" & ws1.Cells(Rows.Count, "J").End(xlUp).Row)

For Each Cell In CheckRange
SearchItem = "*" & Cell.Value & "*"
Set c = SearchRange.Find(SearchItem)
    If Not c Is Nothing Then c.Interior.Color = vbRed
Next

For Each Cell In SearchRange
If Cell.Interior.Color <> vbRed Then
Cell.Interior.Color = vbBlue
End If
Next

End Sub

Yor right, i just missed that one. (Can you see why I need a program lol) This works perfectly! Thankyou so much.

Another question though, Can this be modified to copy the cell format color from, Column A in Sheet2 to ColumnJ in Sheet1?

So if there's a match the matched cell will copy the format of the cell it matched with?

Sure, if you just mean the interior color of the cell:

Sub TomToms()

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

Set CheckRange = ws2.Range("A1:A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row)
Set SearchRange = ws1.Range("J1:J" & ws1.Cells(Rows.Count, "J").End(xlUp).Row)

For Each Cell In CheckRange
SearchItem = "*" & Cell.Value & "*"
Set c = SearchRange.Find(SearchItem)
    If Not c Is Nothing Then 
    c.Interior.Color = Cell.Interior.Color
Next

'For Each Cell In SearchRange
'If Cell.Interior.Color <> vbRed Then
'Cell.Interior.Color = vbBlue
'End If
'Next

End Sub

If you mean copying other formatting, or all the formattings, we can do that, too.

Thank-you very much for this, it works wonderfully I really appreciate it. I do have another question for it but its slightly a different kind so I will make a new post because its a different type of thing I want to do.

Thanks again!

Shoot, there's a problem, Seems like this only works for the first match so if 1117 shows up say 4 times only the first time it shows up ill it be highlighted :/

Sub TomToms()

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

Set CheckRange = ws2.Range("A1:A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row)
Set SearchRange = ws1.Range("J1:J" & ws1.Cells(Rows.Count, "J").End(xlUp).Row)

For Each Cell In CheckRange
SearchItem = "*" & Cell.Value & "*"
Set c = SearchRange.Find(SearchItem)
    If Not c Is Nothing Then
    FirstAdd = c.Address
    Do
        c.Interior.Color = Cell.Interior.Color
        Set c = SearchRange.FindNext(c)
    Loop While Not c Is Nothing And c.Address <> FirstAdd
    End If
    
Next
End Sub

Hi,

Could you define your variables please? I keep getting Variable not defined errors. Thanks.

Hi walruseggman,

Could you define your variables please? I keep getting variable not defined errors. Thanks.

Awesome, works like a charm. Thanks again