Сохранение документа по имени из колонтитула

footer_full = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text 

Sub SaveDocWithFooterText()
Dim w_str As String
Dim w_str_num As String
Dim l_w_str As Long
Dim l_pref As Long
Dim footer_full As String
Dim save_filename As String
'Constants may be altered bu user
Const const_pref As String = "XXX"
Const const_num_suffix As Long = 4
Const typified_name As String = "Typified Name" 'to be specified bu user

save_filename = const_pref
l_pref = Len(const_pref)
'Full footer contents
footer_full = ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Text
w_str = Trim$(footer_full)
'Check prefix
If InStr(footer_full, const_pref) <> 1 Then
    MsgBox "Prefix '" & const_pref & "' is not found at the beginning of the footer"
    GoTo e_SDWF
Else
    l_w_str = Len(w_str)
    If l_w_str <= l_pref Then
        MsgBox "Only the prefix '" & const_pref & "' is found at the beginning of the footer"
        GoTo e_SDWF
    Else
        w_str = Mid$(w_str, l_pref + 1) & " "
        w_str_num = GetStrOfDefChars(w_str, " -", False)
        w_str = w_str_num
        w_str_num = GetStrOfDefChars(w_str, "0123456789", True)
        If Len(w_str_num) <> const_num_suffix Then
            MsgBox "The numeric part of the footer '" & w_str_num & "' does not contain exactly " & _
                    CStr(const_num_suffix) & " digits after the prefix"
            GoTo e_SDWF
        Else
            'Now the footer is verified as correct text. Form the file name for saving.
            save_filename = const_pref & " - " & w_str_num & _
                            "_" & typified_name & "_" & _
                            Format(Now(), "DD.MM.YY")
            'Here you can save the document with the produced file name (save_filename), for example:
            'ActiveDocument.SaveAs FileName:="C:\Temp\" & save_filename & ".docx", AddToRecentFiles:=False
        End If
    End If
End If
e_SDWF:
End Sub
Function GetStrOfDefChars(input_line As String, defchars As String, filt_flag As Boolean) As String
'Функция возвращает подстроку из левой части строки input_line.
'Состав подстроки зависит от состава строки defchars и флажка filt_flag:
'- если filt_flag = true,  то в выходную строку добавляются символы входной строки до тех пор,
'                          пока не встретится символ, отсутствующий в строке defchars
'- если filt_flag = false, то символы входной строки пропускаются до тех пор,
'                          пока не встретится символ, присутствующий в строке defchars
'                          (возвращается остаток строки от этого символа до конца input_line)
'ПРИМЕРЫ
' s = GetStrOfDefChars("123ght", "0123456789.", True)  '= в s значение "123"
' s = GetStrOfDefChars("., abc123ght", ":;., ", False) '= в s значение "abc123ght"
Dim ic As Long
Dim s_out As String
Dim nextchar As String

s_out = ""
If (filt_flag = True) Then
    For ic = 1 To Len(input_line)
        nextchar = Mid$(input_line, ic, 1)
        If InStr(defchars, nextchar) > 0 Then
            s_out = s_out & nextchar
        Else
            Exit For
        End If
    Next ic
Else
    For ic = 1 To Len(input_line)
        nextchar = Mid$(input_line, ic, 1)
        If InStr(defchars, nextchar) = 0 Then
            s_out = Mid$(input_line, ic)
            Exit For
        End If
    Next ic
End If
GetStrOfDefChars = s_out
End Function

Sub ПереименоватьДок()
Dim oDoc As Document
Dim sName, sFullName, sText As String
Dim iInstr As Integer
Set oDoc = ActiveDocument
sName = oDoc.Name
sFullName = oDoc.FullName
For i = 1 To oDoc.Sections(1).Footers.Count
sText = oDoc.Sections(1).Footers(i).Range.Text
iInstr = InStr(sText, "СТБ " & Chr(150) & Chr(32))
If iInstr >= 1 Then
    sText = Mid(sText, iInstr, 10): GoTo RenameLine
End If
Next i
RenameLine:
If sText = "" Then MsgBox "Текст не обнаружен": Exit Sub
sText = Replace(sText, Chr(32), "") & "_ТиповоеИмя_" & Date
ActiveDocument.SaveAs2 FileName:=Replace(sFullName, sName, sText & ".doc")
End Sub

Debug.Print sText