Задача (поиска и замены)

[Ghost Mouse]

подскажите, пожалуйста, что можно сделать для замены в документе записей типа:

Пример : У меня есть серый Cat и большая DOG из fusion reactor возле его Clean будки

Результат : У меня есть серый Кот и большая Собака из ядерного реактора возле его чистой будки .

(Можно реализовать как нибудь быстрее через перебор всех слов , более 1000 зап обрабатываются , где то 40 сек ) , есть реализация через массив (но 'тоже тормозит , плюс придётся вручную 1000 зап (сейчас 390 зап и лагает при замене))

1-ый Вариант

Sub engtorus (sin$, sout$)
 
Selection.EndKey wdStory  
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = sin$
        .Replacement.Text = sout$
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
 
Sub Bot()
 
 engtorus "DOG", "Собака"
 engtorus "Cat", "Кот"
 engtorus "fusion reactor", "термоядерный реактор"
 engtorus "Clean", "Чистой"

2-ой Вариант

Sub qwe()
Dim str As Range
Dim FindText As Variant
Dim ReplaceText As Variant
Dim i As Long
Set str = ActiveDocument.Range
FindText = Array("DOG", "Сat ", "fusion reactor", "Clean")
ReplaceText = Array("Собака", "Кот", "термоядерный реактор", "чистой")
With str.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindsTextop
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Format = True
.MatchCase = True
For i = LBound(FindText) To UBound(FindText)
.Text = FindText(i)
.Replacement.Text = ReplaceText(i)
.Execute Replace:=wdReplaceAll
Next i
End With
End Sub