Замена Excel-Word не работает для колонтитулов

[SPOILER]Sub post_data_to_Office()
 Dim MyDoc As Word.Document
 Dim FileName, strValue, NameStr, ValueStr As String
 Dim i As Integer
'file_text, update_links, read_only, format, prot_pwd, write_res_pwd, ignore_rorec, file_origin, custom_delimit, add_logical, editable, file_access, notify_logical, converter
'Application.SendKeys "Book.xls"
'Application.Dialogs(xlDialogFindFile).Show
'FileName = Application.Dialogs(xlDialogOpen).Show(Arg1:="*.docx", arg3:=true)
 
FileName = Application.GetOpenFilename("Word Files (*.docx), *.docx")
'Application.FindFile
If FileName <> False Then
Set MyDoc = GetObject(FileName)
MyDoc.Application.Visible = True
 
With Application
.Goto .Range("B1")
 
Set tbl = ActiveCell.CurrentRegion
tbl.Offset(0, 0).Resize(tbl.Rows.count, _
    tbl.Columns.count).Select
For i = 1 To tbl.Rows.count - 1
 ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
 NameStr = ActiveCell.Value
 ValueStr = ActiveCell.Offset(rowOffset:=0, columnOffset:=1).Value
  With MyDoc.Content.find
  .Text = NameStr
  .Replacement.Text = ValueStr
  .Forward = True
  .Wrap = wdFindContinue
  .Execute Replace:=wdReplaceAll
 End With
 
Next i
End With
MyDoc.Application.Activate
Set MyDoc = Nothing
Else
MsgBox ("ôàéë íå âûáðàí!")
End If
End Sub[/SPOILER]

    For Each aStory In MyDoc.StoryRanges
        With aStory.Find
            .Text = NameStr
            .Replacement.Text = ValueStr
            .Forward = True
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next aStory