Sub proverka()
Dim x, i&
Dim txt$
Dim Etalon, r&, c&, st&
Etalon = Sheets("Эталонный справочник").[A1:J1000].Value
x = Range("A1:A" & [A65535].End(xlUp).Row).Value
      For i = 1 To UBound(x)
          txt = CStr(x(i, 1))
          If txt <> "" Then
              Cells(i, 1).Font.Color = vbRed
              For r = LBound(Etalon) To UBound(Etalon)
                  For c = 1 To 10
                      If Trim(Etalon(r, c)) <> "" And Len(Trim(Etalon(r, c))) > 1 Then
                          st = InStr(1, txt, Trim(Etalon(r, c)))
                          If st > 0 Then
                    Cells(i, 1).Characters(Start:=st, Length:=Len(Trim(Etalon(r, c)))).Font.Color = vbGreen
                    st = 0
                          End If
                      End If
                  Next
              Next
          End If
      Next
End Sub