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