Форум по VBA и MS Office

Sub MergeDocuments()

    Dim doc As Document, MyPath As String, MyName As String
   
    Application.ScreenUpdating = False
    MyPath = "C:\Users\User\Desktop\Новая папка"
    MyName = Dir(MyPath & "\" & "*.doc*")
    Do While MyName <> ""
      If MyName <> ActiveDocument.Name Then
          Set doc = Documents.Open(MyPath & "\" & MyName)
          Selection.WholeStory
          Selection.Copy
          Windows(1).Activate
          Selection.EndKey Unit:=wdLine
          Selection.TypeParagraph
          Selection.Paste
          doc.Close False
      End If
      MyName = Dir
    Loop
    Application.ScreenUpdating = True

End Sub

Sub MergeDocuments()

    Dim docSrc As Document, docRes As Document
    Dim MyPath As String, MyName As String
   
    Application.ScreenUpdating = False
   
    ' Создание пустого ворд-файла и присвоение ему имени "docRes".
        ' Затем в коде можно обращаться к этому файлу по этому имени.
    Set docRes = Documents.Add
   
    MyPath = "C:\Users\User\Desktop\Новая папка"
    MyName = Dir(MyPath & "\" & "*.doc*")
    Do While MyName <> ""
   
        Set docSrc = Documents.Open(MyPath & "\" & MyName)
        ' Копирование всего основного текста файла (без колонтитулов).
        docSrc.Range.Copy
        ' Вставка абзаца в конце файла.
        docRes.Range.InsertParagraphAfter
        ' Вставка содержимого буфера обмена в новый файл.
            ' docRes.Range(docRes.Range.End - 1, docRes.Range.End - 1) - это положение
            ' перед последним символом "знака абзаца".
        docRes.Range(docRes.Range.End - 1, docRes.Range.End - 1).Paste
        ' Закрытие файла-источника без сохранения.
        docSrc.Close SaveChanges:=False
       
        MyName = Dir
    Loop
    Application.ScreenUpdating = True
   
End Sub