Вставка текста в несколько файлов

Sub Insert()
On Error Resume Next
Dim picker As New FilePicker
Dim wordApp As Application
Dim wordDocument As Word.Document
 
picker.pickFile "Word files", Array("*.doc;*.docx;*.docm")
If UBound(picker.items) < 0 Then: Exit Sub
 
 
Set wordApp = New Application
wordApp.Visible = True
 
Application.DisplayAlerts = wdAlertsNone
wordApp.DisplayAlerts = wdAlertsNone
 
For Each FileName In picker.items
Set wordDocument = wordApp.Documents.Open(FileName)
With wordDocument
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.TypeText Text:="=====+++++======"
 
End With
wordDocument.Close SaveChanges:=True
Next
wordApp.Quit
End Sub

Sub hhh()
    ActiveDocument.Shapes(1).Select ' выделяем первую надпись в активном документе
    Selection.Copy                  ' копируем
    Documents.Open ("e:\2.docx") ' открываем документ для вставки
    Selection.Paste     ' собственно вставка с выделением
    ' записано макрорекордером и скорректировано
    With Selection.ShapeRange
        ' горизонтальная и вертикальная позиция относительно страницы
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
        .RelativeVerticalPosition = wdRelativeVerticalPositionPage
        .Left = CentimetersToPoints(2)  ' слева 2 см
        .LeftRelative = wdShapePositionRelativeNone
        .Top = CentimetersToPoints(15)   ' от верха 15 см
        .TopRelative = wdShapePositionRelativeNone
    End With
End Sub