Форум по 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

Private Sub UserForm_Initialize()

    Dim MyPath As String, MyName As String
   
    ' Запись в листбокс полных имён и имён ворд-файлов.
    MyPath = "C:\Users\User\Desktop\Новая папка"
    MyName = Dir(MyPath & "\" & "*.doc*")
    Do While MyName <> ""
        Me.ListBox1.AddItem MyName
        Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = MyPath & "\" & MyName
      MyName = Dir
    Loop
   
End Sub

Private Sub CommandButton2_Click()
    ' Обработка файлов, которые записаны в листбокс.
    MergeDocuments
End Sub

Private Sub MergeDocuments()

    ' Обработка файлов, которые записаны в листбокс.
   
    Dim doc As Document
    Dim i As Long
   
    Application.ScreenUpdating = False
    For i = 0 To Me.ListBox1.ListCount - 1
        Set doc = Documents.Open(Me.ListBox1.List(i, 1))
        Selection.WholeStory
        Selection.Copy
        Windows(1).Activate
        Selection.EndKey Unit:=wdLine
        Selection.TypeParagraph
        Selection.Paste
        doc.Close False
    Next i
    Application.ScreenUpdating = True
   
End Sub