利用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 = "xxxx" & empId
           ActiveDocument.SaveAs "D:\" & strNewFileName, Password:=CStr(pwd), WritePassword:="xxxxx", 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