=ПОИСК()

Sub iLetterRed()
Dim i As Long
Dim j As Integer
Dim iLastRow As Long
Dim re As Object
Dim objMatches As Object
Dim objMatch As Object
  iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    Range("A1:A" & iLastRow).Font.ColorIndex = 0
    Range("B1:B" & iLastRow).ClearContents
      Set re = CreateObject("VBScript.RegExp")
        re.Global = True
        re.Pattern = "1Я|3К"
  For i = 1 To iLastRow
     Set objMatches = re.Execute(Cells(i, "A"))
       If objMatches.Count <> 0 Then
          For j = 0 To objMatches.Count - 1
             Set objMatch = objMatches.Item(j)
               Cells(i, "B") = Cells(i, "B") & objMatch & " "
             With Cells(i, "A").Characters(Start:=objMatch.FirstIndex + 1, Length:=objMatch.Length).Font
                .ColorIndex = 3
             End With
          Next
       End If
    Next
      Set re = Nothing
End Sub