Замена текста в выделенном фрагменте

Selection.MoveDown Unit:=wdScreen, Count:=1, Extend:=wdExtend (выделяет необходимый текст до конца дока)
 
Dim sText As Range
Dim vFindText As Variant
Dim vReplText As Variant
Dim i As Long
Set sText = ActiveDocument.Range
vFindText = Array("Санкт-Петербург", "Москва")
vReplText = Array("СПб.", "М.")
With sText.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Format = True
.MatchCase = True
For i = LBound(vFindText) To UBound(vFindText)
.Text = vFindText(i)
.Replacement.Text = vReplText(i)
.Execute Replace:=wdReplaceAll
Next i
End With

  Selection.EndKey Unit:=wdStory, Extend:=wdExtend

'заменить
Set sText = ActiveDocument.Range
'на
Set sText = Selection.Range