Макрос на замену каждого третьего слова в тексте на код EQ - VBA

Формулировка задачи:

Здравствуйте! Помогите, пожалуйста, создать макрос для замены каждого третьего слова в тексте на код EQ. Вот собственно в чем вопрос: Исходный текст:

Однако громадные возможности компьютеров оказали влияние не только на технические аспекты этого вида деятельности.

Измененный текст:

Однако громадные {eq возможности} компьютеров оказали {eq влияние} не только {eq на} технические аспекты {eq этого} вида деятельности.

Как я это делаю. В ручную выполняю макрос:

                    Листинг программы
                
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "eq заменяемое слово", PreserveFormatting:=False

Задача: автоматизировать макросом процесс замены слов в тексте на поле вида {eq "каждое третье слово в тексте"}. Должно получиться, что в макросе выполняется 1)Поиск в тексте каждого третьего слова 2) Замена этого слова на поле вида {eq "слово"}. Визуально, в тексте не видно поля {eq любое слово} выглядит это так: На деле это выглядит вот так: Или такой вариант: Макрос, должен уметь: -определять границу каждой второй пары слов; -иметь свою базу слов, для каждого третьего слова (для вашего примера: возможности; влияние; на; этого); -вставлять после каждого второго слова, Поле EQ (Текст из базы макроса). Какие будут идеи?

Решение задачи: «Макрос на замену каждого третьего слова в тексте на код EQ»

textual
                            Листинг программы 
                        
 
                            
                        
Sub EQScriptFM()
Dim w As Range, j&, s$, nf0&, nf&, nw&, d0#, d#, d00#, r As Range
  Application.ScreenUpdating = False
  d00 = Now
  d0 = d00 + #12:00:01 AM#
  Set w = ActiveDocument.Range
  nw = w.End
  With w.Find
    .ClearFormatting
    .Text = "<*>*<*>*<*>"
'    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
  End With
  While w.Find.Execute
    Set r = ActiveDocument.Range(w.Words.Last.Start, w.End)
        s = r.Text
        With w.Fields.Add(Range:=r, Type:=wdFieldEmpty)
          .Code.Text = "eq " & Trim$(s)
        End With
        nf = nf + 1
        d = Now
        If d >= d0 Then
          Application.StatusBar = (w.Start - 5 * nf) * 100 \ nw & "% " & nf - nf0 & " полей/сек"
          DoEvents
          nf0 = nf
          d0 = d + #12:00:01 AM#
        End If
      w.Collapse wdCollapseEnd
  Wend
  Application.ScreenUpdating = True
  d = Int((d - d00) * 86400)
  If d = 0 Then d = 1
  s = nf & " полей за " & d & " сек, " & Format(nf / d, "0.0 полей/сек")
  MsgBox s, vbInformation
  Debug.Print s
End Sub