vba实现按特定的字符段落拆分word文档

下面代码把原文档按照指定的标识（这里是“END”）进行拆分。拆分之后的文档生成在源文档当前目录下，文件名后面附加“_1”、“_2”、“_3”等。

Option Explicit

Const Token = "END"

Sub SplitDocumentByToken()

Dim oNewDoc As Document

Dim strSrcName As String, strNewName As String

Dim nStart As Integer, nEnd As Integer, nIndex As Integer

Dim fContinue As Boolean

Dim fso As Object

Set fso = CreateObject("Scripting.FileSystemObject")

strSrcName = ActiveDocument.FullName

nIndex = 1

fContinue = True

Selection.StartOf WdUnits.wdStory

Do While fContinue

nStart = Selection.Start

Selection.Find.ClearFormatting

With Selection.Find

.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

End With

If Selection.Find.Execute Then

nEnd = Selection.End

Else

nEnd = ActiveDocument.Content.End

fContinue = False

End If

ActiveDocument.Range(nStart, nEnd).Copy

strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), _

fso.GetBaseName(strSrcName) & "_" & nIndex & "." & fso.GetExtensionName(strSrcName))

Set oNewDoc = Documents.Add

Selection.Paste

oNewDoc.SaveAs strNewName

oNewDoc.Close False

nIndex = nIndex + 1

Selection.Collapse WdCollapseDirection.wdCollapseEnd

Loop

Set oNewDoc = Nothing

Set fso = Nothing

MsgBox "结束！"

End Sub