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