Sub PromptReplace()
Dim oRngStart As Word.Range
Dim oRng As Range, lngIndex As Long
Dim arrFnd() As String, arrRpl() As String
Set oRngStart = Selection.Range
'find terms
arrFnd = Split("tot;tow;trail;contact;delivery;fist;form;latter;diffused;" _
& "singed;sing;asset;tortuous;emotion;owning;statue;conversion", ";")
'replace terms
arrRpl = Split("to;twos;trial;contract;deliver;first;from;later;defused;" _
& "signed;sign;assert;tortious;motion;owing;statute;conversation", ";")
 
For lngIndex = 0 To UBound(arrFnd)
For Each oRng In ActiveDocument.StoryRanges
With oRng.Find
.ClearFormatting
.Text = arrFnd(lngIndex)
.Forward = True
.Wrap = wdFindStop
While .Execute
Application.ScreenRefresh
oRng.Select
Select Case MsgBox("Replace " & Chr(34) & arrFnd(lngIndex) & Chr(34) & " with " & Chr(34) & arrRpl(lngIndex) & Chr(34) & "?", _
vbYesNoCancel + vbDefaultButton1, "Replace")
Case vbYes
oRng.Text = arrRpl(lngIndex)
Case vbCancel
GoTo lbl_Exit
End Select
oRng.Collapse wdCollapseEnd
Wend
End With
Next oRng
Next lngIndex
lbl_Exit:
oRngStart.Select
Set oRng = Nothing: Set oRngStart = Nothing
End Sub