The routine that I first sent you to could do one at a time. This is similar but I also show how to use an array with it. 

Dim wdApp As Object, WD As Object

Sub Test_SearchReplaceInDocKeep()
  Dim a(1 To 2, 1 To 2) As Variant, i As Integer

  SearchReplaceInDocKeep "U:\Ken\SearchReplaceInDocKeep.doc", "Tom", 1, True, False
  
  a(1, 1) = "****"
  a(2, 1) = 2
  a(1, 2) = "Harry"
  a(2, 2) = 3
  For i = 1 To 2
    SearchReplaceInDocKeep "U:\Material\umtr121\SearchReplaceInDocKeep.doc", a(1, i), a(2, i), True, False
  Next i
  
  SearchReplaceInDocKeep "U:\Material\umtr121\SearchReplaceInDocKeep.doc", "Ken", 4, True, True
End Sub


Sub SearchReplaceInDocKeep(doc As String, sFind As Variant, sReplace As Variant, _
    Optional docVisible As Boolean = True, _
    Optional closeDoc As Boolean = True)
    
    Const wdFindContinue = 1
    Const wdReplaceAll = 2
        
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then Set wdApp = CreateObject("Word.Application")
    On Error GoTo 0
     
    If Dir(doc) = "" Then Exit Sub
    Set WD = wdApp.Documents.Open(doc)
    wdApp.Visible = docVisible
    
    With WD.Content.Find
      .Text = sFind
      .Replacement.Text = sReplace
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = True
      .MatchWholeWord = True
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute Replace:=wdReplaceAll
    End With
        
    If closeDoc Then
        'Set WD = Nothing
        'Set wdApp = Nothing
        wdApp.Quit
    End If
End Sub