Сравнение диапазонов на НЕ полное совпадение

Sub Find_Matches()
Dim CompareRange As Variant, x As Variant, y As Variant
Set  CompareRange = Workbooks("Книга1").Worksheets("Лист2").Range("A1:A180")
For Each x In Selection
For Each y In CompareRange
If x = y Then x.Interior.ColorIndex = 3
Next y
Next x
End Sub

Private Sub Find_Matches()
    Dim CompareRange As Range, x As Range, y As Range
    Set CompareRange = Workbooks("Книга1.xls").Worksheets("Лист2").Range("A1:A180")
    For Each x In Selection
        For Each y In CompareRange
            If InStr(1, y, x, vbTextCompare) > 0 Then x.Interior.ColorIndex = 3
            'If y Like "*" & x & "*" Then x.Interior.ColorIndex = 3
        Next y
    Next x
End Sub

Private Sub Find_Matches2()
    Dim CompareRange As Range, x As Range
    Set CompareRange = Application.Range("Лист2!A1:A180")
    For Each x In Selection
        If Not CompareRange.Find(CStr(x), , xlFormulas, _
        xlPart) Is Nothing Then x.Interior.ColorIndex = 3
    Next
End Sub

Private Sub Find_Matches2()
    Dim CompareRange As Range, x As Range, y As Range
    Set CompareRange = [Лист2!A:A].SpecialCells(xlConstants, xlTextValues)
    
    Selection.Interior.ColorIndex = xlNone
    
    For Each x In CompareRange
        Set y = Selection.Find(CStr(x), , xlValues, xlPart)
        If Not y Is Nothing Then y.Interior.ColorIndex = 3
    Next
End Sub

Private Sub Find_Matches()
    Dim CompareRange As Range, x As Range, y As Range
    Set CompareRange = Worksheets("Лист2").Range("A1:A180")
    
    Selection.Interior.ColorIndex = xlNone
    
    For Each x In Selection
        If Not IsEmpty(x) Then
           For Each y In CompareRange
               If InStr(1, y, x, vbTextCompare) > 0 Then x.Interior.Color = vbRed
           Next y
        End If
    Next x
End Sub

Private Sub Find_Matches()
    Dim CompareRange As Range, x As Range, y As Range
    Set CompareRange = Worksheets("Лист2").Range("A1:A180")
    
    Application.ScreenUpdating = False 'Имеет смысл использ. если выделено много ячеек
    Selection.Interior.ColorIndex = xlNone
    
    For Each y In CompareRange
        If Not IsEmpty(y) Then
           For Each x In Selection
               If InStr(1, x, y, vbTextCompare) > 0 Then x.Interior.Color = vbRed
           Next x
        End If
    Next y
    
    Application.ScreenUpdating = True
End Sub

Private Sub Find_Matches2()
    Dim CompareRange As Range, x As Range, y As Range, a$
    Set CompareRange = [Лист2!A:A].SpecialCells(xlConstants, xlTextValues)
    
    Selection.Interior.ColorIndex = xlNone
    
    For Each x In CompareRange
        Set y = Selection.Find(x, , xlValues, xlPart)
        If Not y Is Nothing Then
           a = y.Address
           Do
                y.Interior.ColorIndex = 3
                Set y = Selection.FindNext(y)
           Loop While y.Address <> a
        End If
    Next
End Sub