Find and Replace Word Doc from Excel Tables

I am trying to create an order form in excel that can be populated, then with the press of a button complete a word-based order form (that will save as PDF) to send to customers.

I know this isn't the best way of doing it - but with the company I'm working for, there are ... difficulties with implementing large changes, so this is my middle ground proof of concept to get the director on board.

Anyway... this is my code. it works fine! right up until the bit in the word document that is in a table. Then the find and replace seems to fail. For clarity - the section marked 'order form' is the part that just refuses to work.

Edit: to include before/after screenshots Before After

Any advice?

Sub ReplaceText()Dim wApp As Object
Set wApp = CreateObject(Class:="Word.Application")
wApp.Visible = True

Set wDoc = wApp.Documents.Add(Template:="FILE LOCATION", NewTemplate:=False, DocumentType:=0)

With wDoc

'Customer Information


    .Application.Selection.Find.Text = "<FT1>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("B5")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<FT2>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("B2")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<FT3>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("B3")
    .Application.Selection.EndOf

'Customer Address

    .Application.Selection.Find.Text = "<AD1>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("B4")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<AD2>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("B12")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<AD3>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("C12")
    .Application.Selection.EndOf

'Order Form
'Column 1

    .Application.Selection.Find.Text = "<Q1>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("A23")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<Q2>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("A24")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<Q3>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("A25")
    .Application.Selection.EndOf

'column2

    .Application.Selection.Find.Text = "<DESC1>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("B23")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<DESC2>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("B24")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<DESC3>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("B25")
    .Application.Selection.EndOf

'column3

    .Application.Selection.Find.Text = "<IC1>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("C23")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<IC2>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("C24")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<IC3>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("C25")
    .Application.Selection.EndOf
    
    'Column4
    
    .Application.Selection.Find.Text = "<RM1>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("D23")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<RM2>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("D24")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<RM3>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("D25")
    .Application.Selection.EndOf

'Column5

    .Application.Selection.Find.Text = "<CTM1>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("E23")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<CTM2>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("E24")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<CTM3>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("E25")
    .Application.Selection.EndOf

'Total Price

    .Application.Selection.Find.Text = "<TP1>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("C31")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<TV1>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("C32")
    .Application.Selection.EndOf
    
    .Application.Selection.Find.Text = "<TC1>"
    .Application.Selection.Find.Execute
    .Application.Selection = Range("C33")
    .Application.Selection.EndOf
    
    .SaveAs2 Filename:=("FILE LOCATION")
    'FileFormat:=wdFormatXMLDocument, AddtoRecentFiles:=False

End With

End Sub

Solution

You have a lot of code which would be easier to manage if you create a mapping table to link each token with its corresponding value source range.

For example:

Option Explicit

Sub ReplaceText()
    
    Dim wApp As Object, wDoc As Object, rngMap As Range, rw As Range, wsData As Worksheet
    Dim res As Boolean, token As String, txt
    
    Set wApp = GetObject(Class:="Word.Application") 'using an open Word document for testing....
    
    wApp.Visible = True
    
    Set wDoc = wApp.Documents(1)
    
    Set wsData = ThisWorkbook.Worksheets("Data") 'for example
    'reference mapping table
    Set rngMap = ThisWorkbook.Worksheets("Mapping").ListObjects(1).DataBodyRange
    
    For Each rw In rngMap.Rows
        token = rw.Cells(1).Value                   'placeholder to be replaced
        txt = wsData.Range(rw.Cells(2).Value).Value 'value to replace with
        res = ReplaceToken(wDoc, token, txt)
        rw.Interior.COLOR = IIf(res, vbGreen, vbRed) 'flag succeed/fail
    Next rw
    
End Sub

'In word document `doc`, replace `<token>` with `txt`
'Return true/false depending on whether a replacement was made
Function ReplaceToken(doc As Object, token As String, txt) As Boolean
    Const wdReplaceAll = 2 'define Word constant
    Dim rng As Object
    Set rng = doc.Content
    ReplaceToken = rng.Find.Execute(FindText:="<" & token & ">", _
                                    ReplaceWith:=txt, _
                                    Replace:=wdReplaceAll)
End Function

Mapping table looks like this: