Infinite loop replacing blanks with text

The sequence of tasks is correct but does not go to completion.

I think that the problem arises at some point after this line

    LastRow = .Range("G9999").End(xlUp).Row  'Determine Last Row in Table`

    For CustRow = 8 To LastRow

but I am not sure what is wrong with it.

    Option Explicit

    Sub CreateWordDocuments()
    Dim CustRow, CustCol, LastRow, TemplRow As Long
    Dim DocLoc, TagName, TagValue, TemplName, FileName As String
    Dim WordDoc, WordApp As Object
    Dim WordContent As Word.Range
    With Sheet1

        If .Range("B3").Value = Empty Then
            MsgBox "Please select a template from the drop down list"
            .Range("F3").Select
            Exit Sub
        End If
        TemplRow = .Range("B3").Value 'Set Template Row
        TemplName = .Range("F3").Value 'Set Template Name
        DocLoc = Sheet9.Range("F"& TemplRow).Value 'Word Document Filename

        'Open Word Template
        On Error Resume Next 'If Word is already running
        Set WordApp = GetObject("Word.Application")
        If Err.Number <> 0 Then
            'Launch a new instance of Word
            Err.Clear
            'On Error GoTo Error_Handler
            Set WordApp = CreateObject("Word.Application") 'launches word application
            WordApp.Visible = True 'Make the application visible to the user
        End If

        LastRow = .Range("G9999").End(xlUp).Row  'Determine Last Row in Table

        For CustRow = 8 To LastRow
            Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
            TagName = .Cells(CustRow, 7).Value 'Tag Name
            TagValue = .Cells(CustRow, 8).Value 'Tag Value
            With WordDoc.Content.Find
                .Text = TagName
                .Replacement.Text = TagValue
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll 'Find & Replace all instances
            End With
        Next CustRow

        FileName = ThisWorkbook.Path & "\"& .Range("H8").Value & "_"& ".docx"
        WordDoc.SaveAs FileName
        WordDoc.Close
        WordApp.Quit

    End With
    End Sub

The sequence I would like;

1. Open the template I made with the blanks that need to be filled is opened

2. Then the all blanks are replaced with the required text

3. the document saves as another name so the template is unchanged

4. then I can just go into the folder and open up the new word document to make any further changes