Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim Region As String
Dim FoundRegion As Range
iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
Range("C3:C" & iLastRow).Interior.ColorIndex = xlNone
With CreateObject("VBScript.RegExp")
   .IgnoreCase = True
   For i = 3 To iLastRow
     If Not IsNumeric(Left(Cells(i, "B"), 6)) Then
       .Pattern = "[А-ЯЁ]+(?= обл)"
       Region = "нет такой области"
       If .test(Cells(i, "B")) Then Region = .Execute(Cells(i, "B"))(0)
       Set FoundRegion = Worksheets("Индексы").Columns(1).Find(Region, , xlValues, xlWhole)
       If Not FoundRegion Is Nothing Then
         Cells(i, "C") = FoundRegion.Offset(, 1) & ", " & Cells(i, "B")
       Else
         Cells(i, "C") = Cells(i, "B")
         Cells(i, "C").Interior.ColorIndex = 6  'если нет области и индекса, то красим ячейку желтым
       End If
     Else
       Cells(i, "C") = Cells(i, "B")
     End If
   Next
End With
End Sub