Word根据关键字分页VBA程序.doc

Word文档根据关键字分页的VBA程序百度上有人提出这个问题，试着编了下，能实现。Sub 自动分页 Dim PagesKeywod As New Collection Dim StringKeywod As String Dim StringFileName As String StringKeywod = 关键字 StringFileName = 文件名 Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting With Selection.Find .Text = StringKeywod .Replacement.Text = StringKeywod .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchByte = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute While (.Found = True) PagesKeywod.Add (Selection.Information(wdActiveEndPageNumber) .Execute Wend End With If PagesKeywod.Count = 0 Then MsgBox (没有找到关键字,不进行拆分文档处理。) ElseIf PagesKeywod.Count = 1 Then MsgBox (只有一个关键字，不进行拆分文档处理。) ElseIf PagesKeywod(1) = PagesKeywod(PagesKeywod.Count) Then MsgBox (所有关键字在同一页中，不进行拆分文档处理。) Else Dim Doc2 As Document Dim FileNo As Integer Dim PageStart As Integer PageStart = 1 Dim intStart As Integer Dim intEnd As Integer FileNo = 1 Selection.ExtendMode = True Selection.HomeKey Unit:=wdStory For i = 1 To PagesKeywod.Count - 1 If PagesKeywod(i) PagesKeywod(i + 1) Then ActiveDocument.Range(0, 1).Select Selection.GoTo wdGoToPage, wdGoToAbsolute, PageStart intStart = Selection.Start Selection.GoTo wdGoToPage, wdGoToAbsolute, PagesKeywod(i + 1) Selection.Move WdUnits.wdCharacter, -1 intEnd = Selection.End ActiveDocument.Range(intStart, intEnd).Copy PageStart = PagesKeywod(i + 1) Set Doc2 = Documents.Add(Template:=Normal, NewTemplate:=False, DocumentType:=0, Visible:=False) Doc2.Content.Paste ChangeFileOpenDirectory D: Doc2.SaveAs FileName:=StringFileName & FileNo & .doc, FileFormat:=wdFormatDocument, _ LockComments:=False, Password:=, AddToRecentFiles:=True, WritePassword _ :=, ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _ SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _ False FileNo = FileNo + 1 Doc2.Close End If Next i ActiveDocument.Range(0, 1).Select Selection.GoTo wdGoToPage, wdGoToAbsolute, PageStart intStart = Selection.Start Selection.EndKey Unit:=wdStory intEnd = Selection.End ActiveDocument.Range(intStart, intEnd).Copy Set Doc2 = Documents.Add(Template:=Normal, NewTemplate:=False, DocumentType:=0, Visible:=False) Doc2.Content.Paste ChangeFileOpenDirectory D: Doc2.SaveAs FileName:=StringFileName & FileNo & .doc, FileFormat:=wdFormatDocument, _ LockComments:=False, Password:=, AddToRecentFiles:=True, WritePassword _ :=, ReadOnlyRecommended:=False, Embe