Замена из Excel в Worde VBA

Формулировка задачи:

Добрый день. Делаю скриптик для заполнения шаблона word данными из excel. На данный момент не получается выполнить замену в колонтитуле. Скрипт имеет такой код

Sub Zamena3()
 Dim wdApp As Object
 Dim wdDoc As Object
 Set wdApp = CreateObject("Word.Application")
 Dim lngA As Long
 
 lngA = Cells(Rows.Count, 1).End(xlUp).Row 'Последняя заполненная ячейка
 filepath = ActiveWorkbook.Path & "\Документ1.doc"
 If Dir(filepath) <> "" Then
    Set wdDoc = wdApp.Documents.Open(filepath)
 
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "{Метка}"
        .Replacement.Text = "Текст"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    MsgBox "Замена завершена"
 End If
 
 wdDoc.Save
 wdDoc.Close
End Sub

После выполнения скрипта замена не производится. Excel зависает

Решение задачи: «Замена из Excel в Worde VBA»

textual
                            Листинг программы 
                        

                            Sub Zamena()
 Dim wdApp As Object
 Dim wdDoc As Object
 Set wdApp = CreateObject("Word.Application")
 Dim lngA As Long
 
 lngA = Cells(Rows.Count, 1).End(xlUp).Row 'Последняя заполненная ячейка
 filepath = ActiveWorkbook.Path & "\Документ1.doc"
 If Dir(filepath) <> "" Then
    Set wdDoc = wdApp.Documents.Open(filepath)
    For x = 2 To lngA
        If IsEmpty(Cells(x, 1)) = False Then
           wdDoc.StoryRanges(9).Find.Execute Cells(x, 1).Value, False, False, False, False, False, True, 1, False, Cells(x, 2).Value, 2
           wdDoc.Content.Find.Execute Cells(x, 1).Value, False, False, False, False, False, True, 1, False, Cells(x, 2).Value, 2
        End If
    Next x
    wdDoc.Close True
 End If
 
 wdApp.Quit
End Sub
                        