Multiple words replacement
Hello,
Firstly, I am completely new to the Word VBA. I was just wondering, if there is any way to use a macro on my usecase.
Imagine, that you have document, in which you have to change about 50 words (rest of the text is still the same). For example you want to send PF cards to your costumers with heartwarming texts and in every card you want to change name of the customer, mention how long you cooperate and some other stuf.
In the end you have excel sheet with 50 columns (for each costumer) and 10 rows (with specific attributes for every costumer).
In word document i replaced theese 10 words (=attributes) by code names (example: Dear costumer_name, I would like to mention our cooperation_lenght years of cooperation....) and you macro bellow. Answer is how to replace value in Const Replace by value from specific cell in excel sheet.
Code:
Sub DoReplace()
Const Find1 = " customer_name "
Const Replace1 = " Mr. Anderson "
Const Find2 = " cooperation_lenght "
Const Replace2 = " 10 "
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"
.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
End With
With WholeDoc.Find
.Execute Find1, True, True, , , , True, , , Replace1, wdReplaceAll
.Execute Find2, True, True, , , , True, , , Replace2, 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
|