Replacing a string of words in several word documents

[questiontoas]

Hi,

I wonder is someone could help me with a script to do the following:

a) open a series of documents identified by there LAN path which is different for each document
b) replacing an "OLD TEXT" with a "NEW TEXT"; I know that all of the above documents have the OLD TEXT
c) Saving all documents and closing all documents

I found this one on the web but don't know how to change it


Const wdReplaceAll = 2

Set objWord = CreateObject("Word.Application")
objWord.Visible = True

Set objDoc = objWord.Documents.Open("C:\Scripts\Test.doc")
Set objSelection = objWord.Selection

objSelection.Find.Text = "Contoso"
objSelection.Find.Forward = TRUE
objSelection.Find.MatchWholeWord = TRUE

objSelection.Find.Replacement.Text = "Fabrikam"
objSelection.Find.Execute ,,,,,,,,,,wdReplaceAll

Thanks a lot.

I am using Word2010.

[gmayor]

If each file is in a different folder, you will have to identify each folder and the file it contains to the macro and sequentially run the code on those files. If they are all in the same folder (and its subfolders) use http://www.gmayor.com/document_batch_processes.htm which has a function to do that and will deal with the file handling.

[macropod]

If you use a separate file to hold the target file names & paths, you could use a macro like:

Sub ProcessFiles()
Application.ScreenUpdating = False
Dim i As Long, DocTgt As Document, DocSrc As Document
Set DocSrc = Documents.Open("SourceDocumentPath & Name", ReadOnly:=True, AddToRecentFiles:=False)
For i = 0 To UBound(Split(DocSrc.Content.Text, vbCr)) - 1
Set DocTgt = Documents.Open(Split(DocSrc.Content.Text, vbCr)(i), ReadOnly:=False, AddToRecentFiles:=False)
With DocTgt
With .Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Find Text"
.Replacement.Text = "Replacement Text"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
.Close SaveChanges:=True
End With
Next
DocSrc.Close SaveChanges:=False
Set DocSrc = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub
As coded, the macro assumes each target file is listed in a separate line (paragraph). The source file could be a plain text file or another Word document. If you use a Word document, you could add the macro to that document and change:
Set DocSrc = Documents.Open("SourceDocumentPath & Name", ReadOnly:=True, AddToRecentFiles:=False)
to;
Set DocSrc = ActiveDocument
You might then also want to delete the line:
DocSrc.Close SaveChanges:=False

[questiontoas]

Hi Paul,

thank you very much for replying. I copied the paths in a separate .txt document and inserted the link. However, the script stops at the "With .Range.Find" code giving the following error message
Run-time error '91':
Object variable or With block variable not set

Any idea why? Thanks again for the help.

[macropod]

Did you add the filenames to the source file as well, or only the paths? Without the filenames, Word won't know what files to open.

[questiontoas]

Yes. I think the problem is that the text to be replaced is in the header for some documents and not in the main body.

[macropod]

That wouldn't cause the problem, but the code also wouldn't do what you want because header/footer processing requires additional code. See, for example: http://www.excelforum.com/word-formatting-and-general/1001546-macro-to-batch-mass-edit-headers-footers-on-multiple-word-documents-docx-replace-text.html#post3647484

[gmayor]

I get the same error. My text file certainly has the full paths listed, and the header footers shouldn't cause the issue. The problem seems to be that the macro is trying to open a file that doesn't exist. If you add a check for whether the file exists before opening it, the message box shows that only the first document is shown as valid and opened, which was puzzling as all the files in my list exist. On further investigation the issue appears to relate to the split. The vbCr needs to be changed to vbCrLF, at least for my text file. It is worth adding in the validity check and stopping automacros also as they can screw things up.


Sub ProcessFiles()
Application.ScreenUpdating = False
Dim i As Long, DocTgt As Document, DocSrc As Document
Dim strName As Variant
Set DocSrc = Documents.Open("c:\Temp\temp.txt", AddToRecentFiles:=False)
WordBasic.DisableAutoMacros 1
For i = 0 To UBound(Split(DocSrc.Content.Text, vbCrLf))
If FileExists(Split(DocSrc.Content.Text, vbCrLf)(i)) Then
Set DocTgt = Documents.Open(Filename:=Split(DocSrc.Content.Text, vbCrLf)(i), _
AddToRecentFiles:=False)
With DocTgt
With .Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "find text"
.Replacement.Text = "replacement text"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
.Close SaveChanges:=True
Set DocTgt = Nothing
DoEvents
End With
Else
MsgBox Split(DocSrc.Content.Text, vbCrLf)(i) & vbCr & "not opened"
End If
Next i
WordBasic.DisableAutoMacros 0
DocSrc.Close SaveChanges:=False
Set DocSrc = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub


Private Function FileExists(ByVal Filename As String) As Boolean
Dim lngAttr As Long
On Error GoTo NoFile
lngAttr = GetAttr(Filename)
If (lngAttr And vbDirectory) <> vbDirectory Then
FileExists = True
End If
NoFile:
Exit Function
End Function