Function ПОЛУЧИТЬ_ФИО(текст$, искомый_текст$, направление&)
'направление: 2(два слова вперед) или -2(два слова назад)
Dim arr
Dim iKey
Dim I&, N&, a&, b&
arr = Split(Application.Trim(текст), " ")
For Each iKey In arr
  If iKey = искомый_текст Then
    a = IIf(направление < 0, N + направление, N)
    b = IIf(направление < 0, N, N + направление)
    For I = a To b
      ПОЛУЧИТЬ_ФИО = ПОЛУЧИТЬ_ФИО & " " & arr(I)
    Next
  End If
  N = N + 1
Next
End Function

Option Explicit

Sub ExtractText_InStr_Mid_Areas()
    Dim rr As Range
    Set rr = Intersect(Selection, ActiveSheet.UsedRange)
    Set rr = Intersect(rr.Columns(1).EntireColumn, rr)
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim cl As Range
    For Each cl In rr.Cells
        cl.Resize(1, 2).Select
        ExtractText_InStr_Mid
    Next
    rr.Select
    Application.Calculation = Application_Calculation
End Sub

Sub ExtractText_InStr_Mid()
Dim txtLower As String, searchLower As String, matchPos%
Dim arr1, ArrChr, ch, I%, pos%
Dim stPos1%, endPos1%, stPos2%, endPos2%
Const Prob As String = " ", kProb As Integer = 2
arr1 = Selection
    
    ArrChr = Array(vbTab, Chr(160))
For Each ch In ArrChr: arr1(1, 1) = Replace(arr1(1, 1), ch, Prob): Next ch
arr1(1, 1) = Application.WorksheetFunction.Trim(arr1(1, 1))
    
txtLower = LCase(arr1(1, 1)): searchLower = LCase(arr1(1, 2))
matchPos = InStr(1, txtLower, searchLower, vbBinaryCompare)
If matchPos = 0 Then MsgBox "Слово не найдено.", vbInformation: Exit Sub

endPos1 = VBA.InStr(matchPos, arr1(1, 1), Prob) - 1
pos = endPos1 + 2
For I = 1 To kProb
        pos = InStr(pos + 1, arr1(1, 1), Prob)
        If pos = 0 Then Exit For
Next I
If pos = 0 Then endPos2 = Len(arr1(1, 1)) Else endPos2 = pos - 1

stPos2 = VBA.InStrRev(arr1(1, 1), Prob, matchPos) + 1
pos = stPos2 - 2
For I = 1 To kProb
        pos = VBA.InStrRev(arr1(1, 1), Prob, pos - 1)
        If pos = 0 Then Exit For
Next I
If pos = 0 Then stPos1 = 1 Else stPos1 = pos + 1
ReDim ArrChr(1)
ArrChr(0) = VBA.Mid(arr1(1, 1), stPos1, endPos1 - stPos1 + 1)
ArrChr(1) = VBA.Mid(arr1(1, 1), stPos2, endPos2 - stPos2 + 1)
Selection.Offset(0, 2) = ArrChr
End Sub

Function ПОЛУЧИТЬ_ФИО(текст$, искомый_текст$, направление&)
'направление: 2(два слова вперед) или -2(два слова назад)
Dim arr
Dim iKey
Dim I&, N&, a&, b&
arr = Split(Application.Trim(текст), " ")
For Each iKey In arr
    If VBA.InStr(1, iKey, искомый_текст) Then
    a = IIf(направление < 0, N + направление, N):  If a < 0 Then a = 0
    b = IIf(направление < 0, N, N + направление):  If b > UBound(arr) Then b = UBound(arr)
    For I = a To b
      ПОЛУЧИТЬ_ФИО = ПОЛУЧИТЬ_ФИО & " " & arr(I)
    Next
    Exit For
  End If
  N = N + 1
Next
End Function

If VBA.InStr(1, iKey, искомый_текст, 1) Then