如何使用Word VBA拆分文档时保留原文档格式？

问题描述 #

我有一个Word宏，当特定文本出现时会将文档拆分为多个小文档。该文档包含多份合同，指定文本位于每份合同末尾。我可以选择存储位置并为每份合同重命名。请问如何将原文档的格式转移到新生成的文档中？

原宏代码如下：

Sub SplitNotes(delim As String, strFilename As String)
    Dim doc As Document
    Dim arrNotes
    Dim I As Long
    Dim X As Long
    Dim Response As Integer
    Dim fileName As String
    Dim folderPath As String
    Dim dlg As FileDialog

    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    dlg.Title = "Select Folder to Save Files"
    If dlg.Show <> -1 Then
        MsgBox "No folder selected. Exiting..."
        Exit Sub
    Else
        folderPath = dlg.SelectedItems(1)
    End If

    arrNotes = Split(ActiveDocument.Range, delim)
    Response = MsgBox("This will split the document into " & UBound(arrNotes) + 1 & " sections. Do you wish to proceed?", 4)
    If Response = 7 Then Exit Sub
    For I = LBound(arrNotes) To UBound(arrNotes)
        If Trim(arrNotes(I)) <> "" Then
            X = X + 1
            fileName = InputBox("Enter a name for section " & X, "Section Name")
            If fileName = "" Then
                MsgBox "Section " & X & " will be skipped because no name was entered."
            Else
                Set doc = Documents.Add
                doc.Range = arrNotes(I)
                doc.SaveAs folderPath & "\" & fileName & ".docx"
                doc.Close True
            End If
        End If
    Next I
End Sub


Sub test()
    'delimiter & filename
    SplitNotes "(einfach in der Suche eingeben)", "Notes"
End Sub

解决方案 #

原代码中doc.Range = arrNotes(I)仅赋值纯文本，会丢失原格式。要保留格式，需改用带格式的复制粘贴逻辑，直接操作原文档的Range对象。以下是修改后的代码：

Sub SplitNotesWithFormat(delim As String, strFilename As String)
    Dim docOriginal As Document
    Dim docNew As Document
    Dim rngSplit As Range
    Dim arrSplitPoints() As Long
    Dim I As Long
    Dim X As Long
    Dim Response As Integer
    Dim fileName As String
    Dim folderPath As String
    Dim dlg As FileDialog
    Dim currentPos As Long
    
    Set docOriginal = ActiveDocument
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    dlg.Title = "选择保存文件的文件夹"
    If dlg.Show <> -1 Then
        MsgBox "未选择文件夹，程序退出..."
        Exit Sub
    Else
        folderPath = dlg.SelectedItems(1)
    End If

    ' 收集所有分隔符的位置
    currentPos = 1
    ReDim arrSplitPoints(0)
    Do
        Set rngSplit = docOriginal.Range(currentPos, docOriginal.Content.End)
        rngSplit.Find.Execute FindText:=delim, Forward:=True
        If rngSplit.Find.Found Then
            arrSplitPoints(UBound(arrSplitPoints)) = rngSplit.Start
            ReDim Preserve arrSplitPoints(UBound(arrSplitPoints) + 1)
            currentPos = rngSplit.End + 1
        Else
            Exit Do
        End If
    Loop
    ReDim Preserve arrSplitPoints(UBound(arrSplitPoints) - 1) ' 移除最后一个空元素

    ' 计算拆分后的文档数量
    Dim totalSections As Long
    totalSections = UBound(arrSplitPoints) + 2 ' 分隔符数量+1，处理最后一段
    Response = MsgBox("将文档拆分为 " & totalSections & " 个部分，是否继续？", vbYesNo)
    If Response = vbNo Then Exit Sub

    ' 拆分并创建带格式的新文档
    currentPos = 1
    For I = 0 To UBound(arrSplitPoints)
        X = X + 1
        fileName = InputBox("请输入第 " & X & " 个部分的文件名", "文件名")
        If fileName = "" Then
            MsgBox "未输入文件名，跳过第 " & X & " 个部分。"
        Else
            Set rngSplit = docOriginal.Range(currentPos, arrSplitPoints(I))
            Set docNew = Documents.Add
            rngSplit.Copy
            docNew.Range.PasteAndFormat wdFormatOriginalFormatting ' 保留原格式粘贴
            docNew.SaveAs folderPath & "\" & fileName & ".docx"
            docNew.Close True
        End If
        currentPos = arrSplitPoints(I) + Len(delim) ' 跳过分隔符
    Next I

    ' 处理最后一段内容
    X = X + 1
    fileName = InputBox("请输入第 " & X & " 个部分的文件名", "文件名")
    If fileName <> "" Then
        Set rngSplit = docOriginal.Range(currentPos, docOriginal.Content.End)
        Set docNew = Documents.Add
        rngSplit.Copy
        docNew.Range.PasteAndFormat wdFormatOriginalFormatting
        docNew.SaveAs folderPath & "\" & fileName & ".docx"
        docNew.Close True
    End If
End Sub

Sub testWithFormat()
    ' 分隔符 & 文件名（此处文件名参数未使用，可根据需求调整）
    SplitNotesWithFormat "(einfach in der Suche eingeben)", "Notes"
End Sub

修改说明 #

• 替换拆分逻辑：放弃Split函数拆分纯文本数组的方式，改用Find方法定位分隔符位置，直接操作原文档的Range对象，确保格式完整。
• 带格式粘贴：使用Copy+PasteAndFormat wdFormatOriginalFormatting组合，完整复制原文档的内容与格式到新文档。
• 完善边界处理：单独处理分隔符后的最后一段内容，避免遗漏。
• 优化交互提示：将弹窗提示改为中文，适配中文使用场景。

内容的提问来源于stack exchange，提问作者Eriksch1307