Sub ReplaceTextInWordDoc()
''Early binding for Word - assumes reference set
''Assumes macro is in Excel and workbook is open
Dim appWD As Word.Application
Dim docWD As Word.Document
Dim rngWD As Word.Range
Dim wkb As Workbook
Dim wks As Worksheet
Dim rng As Excel.Range
Dim strDoc As String
Dim strFind As String
Dim strText As String
Set wkb = ActiveWorkbook
Set wks = wkb.ActiveSheet
strDoc = "C:\Your\Full\Document\Path\AndName\Here.docx"
On Error Resume Next
Set appWD = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set appWD = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
Set docWD = appWD.Documents.Open(strDoc)
appWD.Visible = True
docWD.SaveAs FileName:= _
"C:\Your\New\Document\Path\AndName\Here.docx", _
FileFormat:=wdFormatDocumentDefault
''*******************
''Repeat the block in between *** for each value that needs to be replaced
strFind = "[First Text]"
strText = wks.Range("A1").Value 'Replace A1 with actual cell address
Set rngWD = docWD.Content
With rngWD.Find
.Text = strFind
.Replacement.Text = strText
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
rngWD.Find.Execute Replace:=wdReplaceAll
''*******************
strFind = "[Second Text]"
strText = wks.Range("B1").Value 'Replace A1 with actual cell address
Set rngWD = docWD.Content
With rngWD.Find
.Text = strFind
.Replacement.Text = strText
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
rngWD.Find.Execute Replace:=wdReplaceAll
docWD.Save
docWD.Close
appWD.Quit
Set docWD = Nothing
Set appWD = Nothing
End Sub