在Word中使用VBA按节分割文档

6108

我使用的是WPS2023
使用邮件合并后生成的大文档，大概每人有3至4页，使用完毕后需要按每人一个单独的Word存档，但我使用以下代码始终错误，请大神指点！
Option Explicit

Const Token As String = "责任公司"

Sub SplitDocumentByToken()
    Dim oNewDoc As Document
    Dim strSrcName As String
    Dim strNewName As String
    Dim nStart As Integer
    Dim nEnd As Integer
    Dim nIndex As Integer
    Dim fContinue As Boolean
    Dim fso As Object

    Set fso = CreateObject("Scripting.FileSystemObject")
    strSrcName = ActiveDocument.FullName
    nIndex = 1
    fContinue = True

    With ActiveDocument
        .StartOf WdUnits.wdStory
        Do While fContinue
            nStart = .Selection.Start
            With .Selection.Find
                .ClearFormatting
                .Text = "^13" & Token & "^13"
                .Replacement.Text = ""
                .Forward = True
                .Wrap = WdFindWrap.wdFindStop
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchByte = False
                .MatchAllWordForms = False
                .MatchSoundsLike = False
                .MatchWildcards = True
                .Execute
            End With

            If .Selection.Find.Found Then
                nEnd = .Selection.End
                .Selection.Collapse Direction:=WdCollapseDirection.wdCollapseEnd
            Else
                nEnd = .Content.End
                fContinue = False
            End If

            .Range(nStart, nEnd).Copy
            strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), _
                                       fso.GetBaseName(strSrcName) & "_" & nIndex & "." & _
                                       fso.GetExtensionName(strSrcName))

            Set oNewDoc = Documents.Add
            oNewDoc.Selection.PasteAndFormat (wdPasteDefault)
            oNewDoc.SaveAs2 strNewName, WdSaveFormat.wdFormatXMLDocument
            oNewDoc.Close False
            Application.CutCopyMode = False ' Clear the Clipboard

            nIndex = nIndex + 1
        Loop
    End With

    Set oNewDoc = Nothing
    Set fso = Nothing
    MsgBox "结束!"
End Sub



后来使用以下代码，始终报错，点击调试最终能成功，但要点击好多次。



Option Explicit

Sub SplitDocumentBySections()
    Dim oSrcDoc As Document
    Dim oNewDoc As Document
    Dim oSection As Section
    Dim oRange As Range
    Dim strSrcName As String
    Dim strNewName As String
    Dim nIndex As Integer
    Dim fso As Object
    Dim oHeader As HeaderFooter
    Dim oFooter As HeaderFooter

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oSrcDoc = ActiveDocument
    strSrcName = oSrcDoc.FullName

    nIndex = 1

    ' 创建新文档并复制原文档的样式
    Set oNewDoc = Documents.Add(Template:=oSrcDoc.AttachedTemplate.FullName, DocumentType:=0)
    oNewDoc.UpdateStylesOnOpen = False
    oNewDoc.UpdateStyles
   
    For Each oSection In oSrcDoc.Sections
        ' 复制分节内容和格式
        Set oRange = oSection.Range
        oRange.End = oRange.End - 1  ' 减去一个字符以避开分节符本身
        
        ' 清空新文档内容，准备粘贴新的分节
        oNewDoc.Content.Delete
        oRange.Copy
        oNewDoc.Content.PasteAndFormat (wdFormatOriginalFormatting)
        
        ' 复制页眉和页脚
        For Each oHeader In oSection.Headers
            If oHeader.Exists Then
                oHeader.Range.Copy
                oNewDoc.Sections(1).Headers(oHeader.Index).Range.PasteAndFormat (wdFormatOriginalFormatting)
            End If
        Next oHeader
        
        For Each oFooter In oSection.Footers
            If oFooter.Exists Then
                oFooter.Range.Copy
                oNewDoc.Sections(1).Footers(oFooter.Index).Range.PasteAndFormat (wdFormatOriginalFormatting)
            End If
        Next oFooter

        ' 构造新文档的文件名
        strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), fso.GetBaseName(strSrcName) & "_Section" & nIndex & "." & fso.GetExtensionName(strSrcName))
        
        ' 保存并关闭新文档
        oNewDoc.SaveAs2 FileName:=strNewName, FileFormat:=oSrcDoc.SaveFormat
        nIndex = nIndex + 1
    Next oSection

    ' 清理
    oNewDoc.Close False
    Set oNewDoc = Nothing
    Set oRange = Nothing
    Set oSrcDoc = Nothing
    Set fso = Nothing

    MsgBox "拆分完成!"
End Sub

闻启学

亲  这个都无用都邮件合并里面的记录数据  

shenjianrong163

邮件合并本身就可以生成单个文件