Sub Объединение()

    Documents.Add DocumentType:=wdNewBlankDocument
    ActiveDocument.SaveAs FileName:="Общий.doc", FileFormat:=wdFormatDocument, _
         LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
        :="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
        SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
        False
     RecentFiles(4).Open
    Selection.WholeStory
    Selection.Copy
    Windows("Общий.doc").Activate
    Windows("222.doc").Activate
    ActiveDocument.Close
    RecentFiles(4).Open
    Selection.WholeStory
    Selection.Copy
    Windows("Общий.doc").Activate
    Windows("111.doc").Activate
    ActiveDocument.Close
    RecentFiles(4).Open
    Selection.WholeStory
    Selection.Copy
    Windows("Общий.doc").Activate
    Windows("333.doc").Activate
    ActiveDocument.Close
    ActiveDocument.Save
    ActiveDocument.Close
End Sub

Sub MergeFiles()
    Dim avFiles, lr As Long
    Dim docAct As Document, docNow As Document

    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = "*.doc*"
        .AllowMultiSelect = True
        If .Show = False Then Exit Sub
        Set docAct = ActiveDocument
        For lr = 1 To .SelectedItems.Count
            Set docNow = Documents.Open(.SelectedItems(lr))
            docNow.Range.Copy
            docAct.Range(docAct.Range.End - 1).Paste
            docAct.Range(docAct.Range.End - 1).InsertBreak Type:=0
            docNow.Close 0
        Next lr
    End With
End Sub

Sub мяу()
    Dim wa As Object, wd As Object, wdt As Object
    Dim cel As Range
    Set wa = CreateObject("Word.Application")
    wa.Visible = True
    Set wd = wa.documents.Add
    For Each cel In ThisWorkbook.Sheets(3).Range("D4:D6")
        Set wdt = wa.documents.Open(cel.Value)
        wdt.Range.Copy
        wdt.Close False
        wa.Selection.Paste
        wa.Selection.TypeParagraph

    Next
    wd.SaveAs2 ThisWorkbook.Path & "\Мяу.doc", 0
    wd.Close False
    wa.Quit False
    Set wa = Nothing: Set wd = Nothing
End Sub