Sub PromptReplace()
Dim Rng As Range, i As Long
Dim strFnd As String, strRpl As String
Dim fnd As String, rpl As String, choice As Integer
'find string
strFnd = "tot;tow;trail;contact;delivery;fist;form;latter;diffused;singed;sing;asset;tortuous;emotion;owning;statue;conversion"
'replace string in same order as strFnd
strRpl = "to;two;trial;contract;deliver;first;from;later;defused;signed;sign;assert;tortious;motion;owing;statute;conversation"
For i = 0 To UBound(Split(strFnd, ";"))
  fnd = Split(strFnd, ";")(i)
  rpl = Split(strRpl, ";")(i)
  For Each Rng In ActiveDocument.StoryRanges
    With Rng
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = fnd
        .Forward = True
        .Wrap = wdFindStop
        .Execute
      End With
      While .Find.Found
        .Duplicate.Select
        choice = MsgBox("Replace " & Chr(34) & fnd & Chr(34) & " with " & Chr(34) & rpl & Chr(34) & "?", _
                vbYesNoCancel + vbDefaultButton1, "Replace")
        If choice = vbYes Then
          .Text = rpl
        ElseIf choice = vbCancel Then
          GoTo endit
        End If
        .Collapse wdCollapseEnd
        .Find.Execute
      Wend
    End With
  Next Rng
Next i
endit:
Set Rng = Nothing
End Sub

.Duplicate.Select