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", "Чистой"

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