VBA合并多个Word文档

Sub MergeDocsWithFirstDocStyles()
    Dim fd As FileDialog
    Dim fileList() As String
    Dim fileCount As Integer
    Dim i As Integer, j As Integer
    Dim temp As String
    
    Dim targetDoc As Document
    Dim sourceDoc As Document
    Dim targetRange As Range
    Dim copyRange As Range
    Dim newDocPath As String
    Dim timeStr As String
    
    ' 1. 弹出文件选择对话框
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "请选择需要合并的Word文档（请确保按正确顺序选择，或文件名可排序）"
        .Filters.Clear
        .Filters.Add "Word 文档", "*.doc; *.docx"
        .AllowMultiSelect = True
        If .Show = -1 Then
            fileCount = .SelectedItems.Count
            If fileCount < 2 Then
                MsgBox "请至少选择两个文档进行合并。", vbExclamation
                Exit Sub
            End If
            ReDim fileList(1 To fileCount)
            For i = 1 To fileCount
                fileList(i) = .SelectedItems(i)
            Next i
        Else
            MsgBox "您取消了操作。", vbExclamation
            Exit Sub
        End If
    End With
    
    ' 2. 对文件路径进行排序（按文件名排序，确保第1章、第2章顺序正确）
    For i = 1 To fileCount - 1
        For j = i + 1 To fileCount
            If Mid(fileList(i), InStrRev(fileList(i), "\") + 1) > Mid(fileList(j), InStrRev(fileList(j), "\") + 1) Then
                temp = fileList(i)
                fileList(i) = fileList(j)
                fileList(j) = temp
            End If
        Next j
    Next i
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = wdAlertsNone
    
    ' 3. 打开第一个文档，并基于它创建一个新文档
    Set targetDoc = Documents.Open(fileList(1))
    
    ' 生成时间字符串（格式如：20231025153000，避免文件名中出现冒号等非法字符）
    timeStr = Format(Now, "yyyymmddhhmmss")
    ' 构建新文档的完整路径（与第一个文档保存在同一个目录下）
    newDocPath = targetDoc.Path & "\合并" & timeStr & ".docx"
    
    ' 将第一个文档另存为新文档。此时 targetDoc 变量就指向了这个新建的文档
    targetDoc.SaveAs2 FileName:=newDocPath, FileFormat:=wdFormatXMLDocument
    
    ' 4. 循环打开后续文档并合并到新文档中
    For i = 2 To fileCount
        Set sourceDoc = Documents.Open(fileList(i))
        
        ' 复制时排除源文档最后的回车符，防止带入其他文档的页面设置引发样式报错
        Set copyRange = sourceDoc.Content
        If copyRange.End > copyRange.Start Then
            Set copyRange = sourceDoc.Range(copyRange.Start, copyRange.End - 1)
        End If
        copyRange.Copy
        sourceDoc.Close SaveChanges:=wdDoNotSaveChanges
        
        ' 在新文档末尾追加内容
        Set targetRange = targetDoc.Content
        targetRange.Collapse Direction:=wdCollapseEnd ' 定位到文档末尾
        
        ' 插入分页符
        targetRange.InsertBreak Type:=wdPageBreak
        targetRange.Collapse Direction:=wdCollapseEnd ' 移动到分页符后
        
        ' 粘贴并使用目标文档（新文档，即第一个文档的复制版）的样式
        On Error Resume Next ' 容错处理
        targetRange.PasteAndFormat wdUseDestinationStyles
        If Err.Number <> 0 Then
            Err.Clear
            targetRange.Paste ' 降级处理
        End If
        On Error GoTo 0
    Next i
    
    ' 保存最终合并好的新文档
    targetDoc.Save
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = wdAlertsNone
    
    MsgBox "文档合并完成！" & vbCrLf & "新文档已保存为：" & newDocPath, vbInformation
End Sub