利用VBA拆分Word每个页面并分别保存

Word中Mail Merge功能之后，分别保存成独立的word文件

Sub BreakOnSection()

Dim a As Excel.Application, ab As Excel.Workbook

Set a = CreateObject("excel.application")

Set ab = a.Workbooks.Open("D:\Book2.xlsx")

  Application.ScreenUpdating = False 'Makes the code run faster and reduces screen flicker a bit.

  ' Used to set criteria for moving through the document by section.

  Application.Browser.Target = wdBrowseSection

  strBaseFilename = ActiveDocument.Name

  On Error GoTo CopyFailed

  'A mail merge document ends with a section break next page.

  For I = 1 To ActiveDocument.Sections.Count

       'Select and copy the section text to the clipboard.

       ActiveDocument.Bookmarks("\Page").Range.Copy

       'Create a new document to paste text from clipboard.

       Documents.Add

       Selection.Paste

       DocNum = DocNum + 1

       With ab

           empId = .Sheets(1).Range("a" & DocNum + 1)

           pwd = .Sheets(1).Range("c" & DocNum + 1)

       End With

           strNewFileName = "Salary" & empId

           ActiveDocument.SaveAs "D:\" & strNewFileName, Password:=CStr(pwd), WritePassword:="admin112233", ReadOnlyRecommended:=True

           ActiveDocument.Close

           ' Move the selection to the next section in the document.

           Application.Browser.Next

       Next I

           'Application.Quit SaveChanges:=wdSaveChanges

       End

CopyFailed:

   'MsgBox ("No final Section Break in " & strBaseFilename)

   Application.Quit SaveChanges:=wdSaveChanges

   End

End Sub