Your loop does not loop to the next document because there is no command to make it do so, it simply loops through the same dcoument.
Your replacement routine will not work either. Assuming that the strings can be in any of the document story ranges, you need to process all those ranges. The code below will only save files that are changed and it processes and saves documents in the Documents folder. The code makes no correction for duplicate filenames, which are simply over-written. If you want to correct for duplicated names, investigate FileNameUnique on my web site.
The find and replace arrays must each have the same number of elements.
Option Explicit
Public Sub MassReplace()
Dim strPath As String
Dim strFile As String
Dim oDoc As Document
Dim oStory As Range
Dim lngCount As Long
strPath = "C:\Users\Anita\"
MsgBox strPath
strFile = Dir$(strPath & "*.doc")
Do While strFile <> ""
Set oDoc = Documents.Open(FileName:=strPath & strFile)
lngCount = 0
For Each oStory In oDoc.StoryRanges
lngCount = lngCount + ProcessRange(oStory)
If oStory.StoryType <> wdMainTextStory Then
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
lngCount = lngCount + ProcessRange(oStory)
Wend
End If
Next oStory
If lngCount > 0 Then oDoc.SaveAs FileName:=(strPath & "1" & oDoc.Name)
oDoc.Close 0
strFile = Dir$()
Loop
MsgBox "Processing completed"
End Sub
Function ProcessRange(oRng As Range) As Long
Dim vFind() As Variant, vRepl() As Variant
Dim oSearch As Range
vFind = Array("facility+++++", "street address+++++", "city state zip+++++", "phone number+++++")
vRepl = Array("Dialysis", "2020 5th Street", "Anytown, NY 11111", "(***) ***-***X")
Dim i As Long
For i = LBound(vFind) To UBound(vFind)
Set oSearch = oRng
With oSearch.Find
Do While .Execute(FindText:=vFind(i))
ProcessRange = 1
oSearch.Text = vRepl(i)
oSearch.Collapse 0
Loop
End With
Next i
End Function