Hi, I've just joined the Forum.


I'm trying to use a Word Macro to replace multiple words in my document. My aim is to take an ebook converted to .txt format and finally convert to an audio book using Natural Reader. Many words are mispronounced by the Audio program so I'm replacing them with phonetic words in my text document.

I have a macro, shown below, that will let me quickly find and replace words, unfortunately I have over 200 words to replace and I've setup the Macro with 10 replacements as an example, so a lot of extra code to get 200. I have an excel spreadsheet with 2 columns A & B. A col has the list of words to find and B col has the list of replacement words. I'm stuck on how to read the excel col A1 & B1 respectively into the Word Macro variables Field1 & Replace1. Then I would complete the Find and Replace and when that was done move down to Excel A2 & B2 and repeating until End of File is reached.
Any help you can give would be appreciated. Please let me know if I wasn't clear, and thanks for looking at this. I have rusty skills..how long ago...think blackboard.

****************************
Sub DoReplace()

Const Find1 = "Arlen "
Const Replace1 = "R. Len "

Const Find2 = "coreling"
Const Replace2 = "core ling"

Const Find3 = "Aleverak"
Const Replace3 = "Aleverack"

Const Find4 = "lean-to"
Const Replace4 = "lean two"

Const Find5 = "Nighteye"
Const Replace5 = "Night eye"

Const Find6 = "people live"
Const Replace6 = "people liv"

Const Find7 = "her wound"
Const Replace7 = "her wund"

Const Find8 = "his wound"
Const Replace8 = "his wund"

Const Find9 = "’s wound"
Const Replace9 = "’s wund"

Const Find10 = "they wound"
Const Replace10 = "they wownd"

Dim FilePick As FileDialog
Dim FileSelected As FileDialogSelectedItems
Dim WordFile As Variant ' FileName placeholder in selected files loop
Dim FileJob As String ' Filename for processing

Dim WorkDoc As Object
Dim WholeDoc As Range
Dim FooterDoc As Range

' On Error GoTo CreateReports_Error

Set FilePick = Application.FileDialog(msoFileDialogFilePicker)

With FilePick
.Title = "Choose Report Template"
.Filters.Clear
.Filters.Add "Word Documents & Templates", "*.do*"
.Filters.Add "Word 2003 Document", "*.doc"
.Filters.Add "Word 2003 Template", "*.dot"
.Filters.Add "Word 2007 Document", "*.docx"
.Filters.Add "Word 2007 Template", "*.dotx"
.Filters.Add "Word 2010 Document", "*.docx"
.Filters.Add "Word 2010 Template", "*.dotx"
.Show
End With

Set FileSelected = FilePick.SelectedItems

If FileSelected.Count <> 0 Then

For Each WordFile In FileSelected

FileJob = WordFile

Set WorkDoc = Application.Documents.Open(FileJob, , , , , , , , , , , False)

Set WholeDoc = WorkDoc.Content
Set FooterDoc = WorkDoc.Sections(1).Footers(wdHeaderFooterPrimary) .Range

With FooterDoc
.Find.Execute Find1, True, True, , , , True, , , Replace1, wdReplaceAll
.Find.Execute Find2, True, True, , , , True, , , Replace2, wdReplaceAll
.Find.Execute Find3, True, True, , , , True, , , Replace3, wdReplaceAll
.Find.Execute Find4, True, True, , , , True, , , Replace4, wdReplaceAll
.Find.Execute Find5, True, True, , , , True, , , Replace5, wdReplaceAll
.Find.Execute Find6, True, True, , , , True, , , Replace6, wdReplaceAll
.Find.Execute Find7, True, True, , , , True, , , Replace7, wdReplaceAll
.Find.Execute Find8, True, True, , , , True, , , Replace8, wdReplaceAll
.Find.Execute Find9, True, True, , , , True, , , Replace9, wdReplaceAll
.Find.Execute Find10, True, True, , , , True, , , Replace10, wdReplaceAll
End With

With WholeDoc.Find
.Execute Find1, True, True, , , , True, , , Replace1, wdReplaceAll
.Execute Find2, True, True, , , , True, , , Replace2, wdReplaceAll
.Execute Find3, True, True, , , , True, , , Replace3, wdReplaceAll
.Execute Find4, True, True, , , , True, , , Replace4, wdReplaceAll
.Execute Find5, True, True, , , , True, , , Replace5, wdReplaceAll
.Execute Find6, True, True, , , , True, , , Replace6, wdReplaceAll
.Execute Find7, True, True, , , , True, , , Replace7, wdReplaceAll
.Execute Find8, True, True, , , , True, , , Replace8, wdReplaceAll
.Execute Find9, True, True, , , , True, , , Replace9, wdReplaceAll
.Execute Find10, True, True, , , , True, , , Replace10, wdReplaceAll
End With

WorkDoc.Save
WorkDoc.Close

Next

End If

MsgBox "Completed"

DoReplace_Exit:

Set WholeDoc = Nothing
Set FilePick = Nothing

Set WorkDoc = Nothing
Set FooterDoc = Nothing

Exit Sub

DoReplace_Error:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure DoReplace of VBA Document ReplaceMulti"
Resume DoReplace_Exit

End Sub

This kind of thing has been discussed numerous times. Do forum searches on BulkFindReplace & UpdateDocuments and numerous approaches will be returned.

__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]

Thanks Paul, my boolean search phrases just didn't have the magic.