Объединение нескольких документов в один

Sub test()
Const strFolder = "c:\test"
Application.ScreenUpdating = False
Dim strFile As String, docTemp As New Document, docResult As New Document, pp As Paragraph, _
i As Integer, n As String
strFile = Dir(strFolder & "*.doc")
Set docTemp = Documents.Add
Application.StatusBar = ""
Do While strFile <> ""
Selection.InsertAfter strFile
Selection.Collapse wdCollapseEnd
Selection.InsertParagraph
strFile = Dir
Loop
Selection.Delete 
Selection.WholeStory
Application.DefaultTableSeparator = "-"
 
Selection.Sort ExcludeHeader:=False, FieldNumber:="Paragraphs", _
    SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _
    FieldNumber2:="", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:= _
    wdSortOrderAscending, FieldNumber3:="", SortFieldType3:= _
    wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending, Separator:= _
    wdSortSeparateByTabs, SortColumn:=False, CaseSensitive:=False, LanguageID _
    :=wdRussian
 
 
n = docTemp.Paragraphs.Count
Set docResult = Documents.Add
For Each pp In docTemp.Paragraphs
i = i + 1
Selection.InsertFile strFolder & Left(pp.Range, Len(pp.Range) - 1)
Application.StatusBar = "Âñòàâêà ôàéëà " & i & " èç " & n
Next
docTemp.Close 0
docResult.Activate
Application.ScreenUpdating = True
Application.StatusBar = False
 
End Sub

ActiveDocument.SaveAs FileName:="C:\temp\Новый.docx", FileFormat:=wdFormatXMLDocument