Sub UpdateHeader()
Dim oDoc As Word.Document
    Dim oSec As Word.Section, rng As Range

Set oDoc = ActiveDocument

    For Each oSec In oDoc.Sections
        Set rng = oSec.Headers(Word.WdHeaderFooterIndex.wdHeaderFooterPrimary).Range
            With rng
                .Tables.Add Range:=rng, NumRows:=1, NumColumns:=1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitWindow
                With .Tables(1)
                    .Borders.InsideLineStyle = wdLineStyleNone
                    .Borders.OutsideLineStyle = wdLineStyleNone
                    .Rows.SetLeftIndent LeftIndent:=-35, RulerStyle:=wdAdjustNone
                    .Cell(1, 1).Range.InlineShapes.AddPicture FileName:="C:\Users\valek\Desktop\Images\шапка.EN4VW (1).jpg", LinkToFile:=False, SaveWithDocument:=True
                End With
            End With
    Next oSec
    MsgBox rng.Tables(1).Cell(1, 1).Range.InlineShapes.Count
    'ActiveDocument.PageSetup.HeaderDistance = CentimetersToPoints(0)
    'With ActiveDocument.ShapeRanges(1)
    With rng.Tables(1).Cell(1, 1).Range.InlineShapes(1)
                .LockAspectRatio = msoFalse
            .Height = .Height * 1.11111
            .Width = .Width * 1.1111
        .LockAspectRatio = msoTrue
    End With
    With ActiveDocument.PageSetup
    
        .HeaderDistance = CentimetersToPoints(0)
        
    End With

Sub Zapusk_Word_iz_Excel_02(strFile As String)
    Dim objWrdApp As Object
    Dim objWrdDoc As Object
    On Error Resume Next
    Set objWrdApp = GetObject(, "Word.Application")  'пытаемся подключится к объекту Word
    If objWrdApp Is Nothing Then
            Set objWrdApp = CreateObject("Word.Application")  'если приложение закрыто - создаем новый экземпляр
            Set objWrdDoc = objWrdApp.Documents.Open(strFile) 'открываем документ Word - документ с таким именем должен существовать
            objWrdApp.Visible = True
    End If
    Set objWrdDoc = objWrdApp.Documents.Open(strFile) 'открываем документ Word - документ с таким именем должен существовать
   
    Set WdRange = objWrdDoc.Content 'задаем переменную для содержимого документа
        WdRange.Find.ClearFormatting
        
        WdRange.Find.Text = "Страхователь"
        WdRange.Find.Execute
        ContractNumber = WdRange.Cells(1).RowIndex 'задаем переменную номера строки необходимого поля в таблице
    Set WdRange = objWrdDoc.Content
        WdRange.Find.Text = "Номер договора страхования"
        WdRange.Find.Execute
        FullName = WdRange.Cells(1).RowIndex

    Set wdTable = WdRange.Tables(1) 'переменная для таблицы документа

    ThisWorkbook.Worksheets(1).Range("A1").Value = Left(wdTable.Cell(ContractNumber, 3), Len(wdTable.Cell(ContractNumber, 3)) - 1) 'вставка значений в Excel на один символ меньше
    ThisWorkbook.Worksheets(1).Range("B1").Value = Left(wdTable.Cell(FullName, 3), Len(wdTable.Cell(FullName, 3)) - 1)             'для избавления от символа

Set WdRange = objWrdDoc.Content
        WdRange.Find.ClearFormatting
        WdRange.Find.Text = "По месту требования"
        WdRange.Find.Execute
        UpDelete = WdRange.Cells(1).RowIndex 'задаем переменную номера строки необходимого поля в таблице
 
        X = wdTable.Columns.Count
   With wdTable
      For i = 1 To X - 1
    
           .Cell(Row:=UpDelete, Column:=i).Merge _
           MergeTo:=.Cell(Row:=UpDelete, Column:=i + 1)
     
      Next i
    End With
        wdTable.Cell(UpDelete, 1).Delete

        Set WdRange = objWrdDoc.Content
        WdRange.Find.ClearFormatting
        WdRange.Find.Text = "О направлении ответа по запросу"
        WdRange.Find.Execute
        ResponseByRequest = WdRange.Cells(1).RowIndex 'задаем переменную номера строки необходимого поля в таблице
        

        X = wdTable.Columns.Count
     With wdTable
      For i = 1 To X - 1
      
      
           .Cell(Row:=ResponseByRequest, Column:=i).Merge _
           MergeTo:=.Cell(Row:=ResponseByRequest, Column:=i + 1)

            
      Next i
    End With
 
       wdTable.Cell(ResponseByRequest, 1).Split NumRows:=7, NumColumns:=1
     wdTable.Cell(ResponseByRequest + 1, 1).Delete
     wdTable.Cell(ResponseByRequest + 1, 1).Delete
     wdTable.Cell(ResponseByRequest + 1, 1).Delete
     wdTable.Cell(ResponseByRequest + 1, 1).Delete
     wdTable.Cell(ResponseByRequest + 1, 1).Delete
     wdTable.Cell(ResponseByRequest + 1, 1).Delete
     
     wdTable.Cell(ResponseByRequest, 1).Split NumRows:=1, NumColumns:=2
     wdTable.Cell(ResponseByRequest, 2).Range.Text = wdTable.Cell(ResponseByRequest, 1).Range.Text
     wdTable.Cell(ResponseByRequest, 2).Range.Font.Size = 11
    wdTable.Cell(ResponseByRequest, 2).Range.Font.Bold = True
     wdTable.Cell(ResponseByRequest, 1).Range.Delete
     
   wdTable.Cell(1, 1).SetWidth _
 ColumnWidth:=49.9, _
 RulerStyle:=wdAdjustNone

Set WdRange = objWrdDoc.Content
        WdRange.Find.ClearFormatting
        WdRange.Find.Text = "И.о. Главного бухгалтера"
        WdRange.Find.Execute
        BottomFirst = WdRange.Cells(1).RowIndex 'задаем переменную номера строки необходимого поля в таблице
Set WdRange = objWrdDoc.Content
        WdRange.Find.ClearFormatting
        WdRange.Find.Text = "доб. 21-75"
        WdRange.Find.Execute
        BottomSecond = WdRange.Cells(1).RowIndex 'задаем переменную номера строки необходимого поля в таблице


A = "Управление бухгалтерского учета"
B = "и отчетности ООО СК «ВТБ Страхование»"
C = "№322/20 от 05.06.2020"
Set wshSwitch = ThisWorkbook.Worksheets("Значения переключателей")

D = wshSwitch.Cells(wshSwitch.Range("A1").Value, 3).Value


F = "Исп. " & wshSwitch.Cells(wshSwitch.Range("A2").Value, 3).Value
          E = wshSwitch.Cells(wshSwitch.Range("A2").Value, 4).Value

objWrdDoc.Range(wdTable.Cell(BottomFirst, ColumnsCount).Range.Start, wdTable.Cell(BottomSecond, ColumnsCount).Range.End).Cells.Delete

wdTable.Rows.Add
wdTable.Cell(BottomFirst, 2).Range.Text = "Руководитель проекта"
wdTable.Cell(BottomFirst, 2).Range.Font.Size = 11
wdTable.Cell(BottomFirst, 2).Range.Font.Bold = True


wdTable.Rows.Add
wdTable.Cell(BottomFirst + 1, 2).Split 1, 2
wdTable.Cell(BottomFirst + 1, 2).Range.Text = A & vbNewLine & B & vbNewLine & C
wdTable.Cell(BottomFirst + 1, 2).Range.Font.Size = 11
wdTable.Cell(BottomFirst + 1, 2).Range.Font.Bold = True


wdTable.Cell(BottomFirst + 1, 3).Range.Text = D
wdTable.Cell(BottomFirst + 1, 3).Range.Font.Size = 11
wdTable.Cell(BottomFirst + 1, 3).Range.Font.Bold = True


 wdTable.Cell(BottomFirst + 1, 3).Range.ParagraphFormat.Alignment = 2

wdTable.Rows.Add
wdTable.Rows.Add

wdTable.Rows.Add
wdTable.Cell(BottomFirst + 4, 2).Range.Text = F
wdTable.Cell(BottomFirst + 4, 2).Range.Font.Size = 10
wdTable.Cell(BottomFirst + 4, 2).Range.Font.Bold = False

wdTable.Rows.Add
wdTable.Cell(BottomFirst + 5, 2).Range.Text = E
wdTable.Cell(BottomFirst + 5, 2).Range.Font.Size = 10
wdTable.Cell(BottomFirst + 5, 2).Range.Font.Bold = False
wdTable.Cell(BottomFirst + 5, 2).VerticalAlignment = wdAlignVerticalTop

    Set objWrdDoc = Nothing
    Set objWrdApp = Nothing 'очищаем переменные Word
End Sub


Sub Certificate()
Dim Response
    Response = MsgBox("Вы уверены, что хотите продолжить?", vbOKCancel, "^_^")
    
    If Response = vbCancel Then
    Exit Sub
        Else
    End If
    Application.ScreenUpdating = False                                            'Отключаем обновление экрана
Dim strFile As String                                                         'Имя текстового файла
Dim xFiles() As String                                                        'Массив с именами найденных файлов
Dim N As Integer                                                              'Кол-во найденных файлов
Dim X As Range
Dim iFirstRow As Long                                                         'Количество строк в файле изначальное
    N = 1
    strFile = Dir(ThisWorkbook.Path & "\" & "*.docx")                              'Поиск всех текстовых файлов в папке
    Do Until strFile = ""
        ReDim Preserve xFiles(1 To N)                                             'Увеличиваем массив до номера последнего найденного файла, с сохранением предыдущих элементов
        xFiles(N) = strFile                                                       'Значение найденного элемента добавляемого в массив
        
        Call Zapusk_Word_iz_Excel_02(ThisWorkbook.Path & "\" & xFiles(N))
        
        strFile = Dir                                                             'Повторить поиcк с теми же аргументами
        N = N + 1
    Loop
    Application.ScreenUpdating = True
End Sub