Sub MergeDocuments()
  Application.ScreenUpdating = False
  MyPath = ActiveDocument.Path
  MyName = Dir(MyPath & "\" & "*.doc")
  i = 0 
  Do While MyName <> ""
  If MyName <> ActiveDocument.Name Then
  Set wb = Documents.Open(MyPath & "\" & MyName)
  Selection.WholeStory
  Selection.Copy
  Windows(1).Activate
  Selection.EndKey Unit:=wdLine
  Selection.TypeParagraph
  Selection.Paste
  i = i + 1
  wb.Close False
  End If
  MyName = Dir
  Loop
  Application.ScreenUpdating = True
  End Sub

Dim WA As Object
Set WA = CreateObject("Word.Application")
WA.Visible = True

Set WDInsert = WA.Documents.Add(ThisWorkbook.Path & "\Рассылка предложений ШАБЛОН.docx"): DoEvents
WDInsert.Activate
WDInsert.Select
'WDInsert.Range.WholeStory
Selection.Delete