Массовая замена слов в документе из списка - VBA

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

Доброго времени суток! В документе есть определенные слова, которые нужно заменять на другие. Этих слов очень много, ведется база того, какие слова должны меняться на другие слова. Сейчас таких слов (словосочетаний) около 300, и эта база пополняется. Нужно, чтобы по нажатию на кнопку, осуществлялась массовая замена этих слов. Для этой цели, сейчас используется такого рода код:

 With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должен выделять"
        .Replacement.Text = "выделяет"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должна выделять"
        .Replacement.Text = "выделяет"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должно выделять"
        .Replacement.Text = "выделяет"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должны выделять"
        .Replacement.Text = "выделяют"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должен выдерживать"
        .Replacement.Text = "выдерживает"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должна выдерживать"
        .Replacement.Text = "выдерживает"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должно выдерживать"
        .Replacement.Text = "выдерживает"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должны выдерживать"
        .Replacement.Text = "выдерживают"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должен выполнять"
        .Replacement.Text = "выполняет"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должна выполнять"
        .Replacement.Text = "выполняет"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должно выполнять"
        .Replacement.Text = "выполняет"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должны выполнять"
        .Replacement.Text = "выполняют"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должен выравнивать"
        .Replacement.Text = "выравнивает"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должна выравнивать"
        .Replacement.Text = "выравнивает"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должно выравнивать"
        .Replacement.Text = "выравнивает"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должны выравнивать"
        .Replacement.Text = "выравнивают"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должен выходить"
        .Replacement.Text = "выходит"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должна выходить"
        .Replacement.Text = "выходит"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

   With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "должно выходить"
        .Replacement.Text = "выходит"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
 End With

Кот работает, но как-то можно его оптимизировать? Очень он уж объемный получается, а в процедуре есть ограничения по объему.

Решение задачи: «Массовая замена слов в документе из списка»

textual
                            Листинг программы 
                        

                            Sub Dy()
Const REPL_WHAT = "должен выделять|должна выделять|должно выделять|должны выделять" 'и т.д.
Const REPL_WITH = "выделяет|выделяет|выделяет|выделяют" 'и т.д.
Dim q$(), w$(), i&
  q = Split(REPL_WHAT, "|")
  w = Split(REPL_WITH, "|")
  For i = 0 To UBound(q)
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = q(i)
        .Replacement.Text = w(i)
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With
  Next
End Sub
                        