Open/Find/Replace/SaveAs not working

[Daydee]

Hello,

I am trying to do the basic things, open/find & replace/save as. It looks like my file is not being read because the code does the saveas, but, the new file is empty. I also want to loop thru the directory to find all the .doc files, but, it looks like it does not loop and only keeps on opening the first file in the directory. Please note that I want to do the find/replace on all occurences in the document. Here is my code so far..
Public Sub MassReplace()
Dim Current As String
Dim file
Current = "C:\Users\Anita\"
MsgBox (Current)
Dim Source As String
Dim StrFile As String
Source = "*.doc"
file = Dir(Current & "*.doc")
StrFile = (Current & Source)

Do While file <> " "
MsgBox (file)
Documents.Open FileName:="C:\Users\Anita\" & StrFile

With Find
Dim FName As String
FName = Replace("facility+++++", "facility+++++", "Dialysis")
MsgBox (FName)
Dim SName As String
SName = Replace("street address+++++", "street address+++++", "2020 5th Street")
Dim CName As String
CName = Replace("city state zip+++++", "city state zip+++++", "Anytown, NY 11111")
Dim TName As String
TName = Replace("phone number+++++", "phone number+++++", "(***) ***-***X")
End With
ActiveDocument.SaveAs FileName:=("C:\Users\Anita\" & "1" & file)
ActiveDocument.Close
Loop
End Sub

thanks
Daydee

[gmayor]

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

[Daydee]

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


Gmayor,
thanks for helping. Can I ask a question...what does lngCount = lngCount + ProcessRange(oStory) do? Why do we need lngCount to execute ProcessRange? I MsgBox lngCount and it looks like it is always zero...

thanks again...

[gmaxey]

After running Graham's code are any of your original files saved as "1 Original File Name"

The function ProcessRange returns long variable (value = 1) if any thing is replaced in the range. Since lngCount starts at 0 for each opened file if the function returns a 1
lngCount will be greater than 0 so the file should be saved with a prefix 1.