vba 用于一对多拆分 Word 文档的宏

Macro for one-to-many splitting of Word documents

提问by Alex R

I have a Word document which is several hundred pages long.

我有一个几百页长的 Word 文档。

I would like to use a macro to automatically create about a dozen or so sub-documents based on certain rules (mainly, occurrence of certain strings in each Section).

我想使用宏根据某些规则（主要是每个部分中出现某些字符串）自动创建大约十几个子文档。

Is this possible? What VBA functions should I read-up on? Does anybody know of any code examples which are even remotely similar and which I may be able to customize for my purposes?

这可能吗？我应该阅读哪些 VBA 函数？有没有人知道任何代码示例甚至远程相似并且我可以根据我的目的进行自定义？

Thanks

谢谢

回答by user998303

It took me a while to figure out how to do this, even with the KB article.

即使使用知识库文章，我也花了一段时间才弄清楚如何做到这一点。

Firstly, you need to put the macro into Normal.dotm... Open C:\Users\Yourname\AppData\Roaming\Microsoft\Templates\Normal.dotm in Word, press Alt-F11, and paste the following into Module1:

首先，您需要将宏放入 Normal.dotm... 在 Word 中打开 C:\Users\Yourname\AppData\Roaming\Microsoft\Templates\Normal.dotm，按 Alt-F11，然后将以下内容粘贴到 Module1 中：

    Sub BreakOnSection()
   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.
   'Note: Document may or may not end with a section break,
   For I = 1 To ActiveDocument.Sections.Count

      'Select and copy the section text to the clipboard.
      ActiveDocument.Bookmarks("\Section").Range.Copy

      'Create a new document to paste text from clipboard.
      Documents.Add
      Selection.Paste
      DocNum = DocNum + 1
      strNewFileName = Replace(strBaseFilename, ".do", "_" & Format(DocNum, "000") & ".do")
     ActiveDocument.SaveAs "C:\Destination\" & strNewFileName
     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

Save the Normal.dotm file.

保存 Normal.dotm 文件。

Executing this code will split a document made up of multiple sections into multiple documents in the C:\Destination directory and then close down Word.

执行此代码会将一个由多个部分组成的文档拆分为 C:\Destination 目录中的多个文档，然后关闭 Word。

You can execute this from the command line via:

您可以通过以下方式从命令行执行此操作：

"c:\Program Files\Microsoft Office\Office12\WINWORD.EXE" /mBreakOnSection "C:\Path to Source\Document with multiple sections.doc"

To process all the .doc files in a directory, create a batch file as follows, and execute it:

要处理一个目录中的所有.doc文件，请按如下方式创建一个批处理文件，并执行它：

@ECHO off
set "dir1=C:\Path to Source"
echo running
FOR %%X in ("%dir1%\*.doc") DO "c:\Program Files\Microsoft Office\Office12\WINWORD.EXE" /mBreakOnSection "%%~X"
echo Done
pause

回答by Ashish Saini

Sub SplitFromSectionBreak()
'use this to split document from section break


   Dim i
   Selection.HomeKey Unit:=wdStory
   Application.ScreenUpdating = False
'------ count how much section in document---------
   MsgBox (ActiveDocument.Sections.count - 1 & " Sections Found In This Document")
'-------set path where file to save----------------
   Dim path As String
   path = InputBox("Enter The Destination Folder You Want To Save Files. ", "Path", "C:\Users\Ashish Saini\Desktop\Section Files\")

   For i = 1 To ActiveDocument.Sections.count - 1
    With Selection.Find
    .Text = "^b"
    .Forward = False
    .Execute
    .Text = ""
    End With

    Selection.Extend

    With Selection.Find
    .Text = "^b"
    .Forward = True
    .Wrap = wdFindStop
    .Execute
    .Text = ""

    End With
        Selection.Copy
        Documents.Add
        Selection.Paste
        Call Del_All_SB
'-----------------------------------------------------------------------
        If Dir(path) = "" Then MkDir path  'If path doesn't exist create one

        ChangeFileOpenDirectory path

        DocNum = DocNum + 1
        ActiveDocument.SaveAs filename:="Section_" & DocNum & ".doc"
        ActiveDocument.Close

    Next i
    path = "c:\"
    ChangeFileOpenDirectory path
End Sub

Sub Del_All_SB()

' this macro also associated with Delete_SectionBreaks()
'TO DELETE ALL SECTIONS IN DOCUMENT

Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting

With Selection.Find
  .Text = "^12"
  .Replacement.Text = ""
  .Forward = True
  .Wrap = wdFindContinue
  .Format = True
  .MatchCase = False
  .MatchWholeWord = False
  .MatchWildcards = False
  .MatchSoundsLike = False
  .MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

End Sub

回答by amini gazar

Split word document by page counter for example use 50 to steps

按页面计数器拆分word文档例如使用50步

Sub Spliter(PartStep)
    If IsEmpty(PartStep) Or Not IsNumeric(PartStep) Then
         Exit Sub
    End If
    Dim i, s, e, x As Integer
    Dim rgePages As Range
    Dim MyFile, LogFile, DocFile, DocName, MyName, MyPages, FilePath, objDoc
    Set fso = CreateObject("scripting.filesystemobject")

    Selection.GoTo What = wdGoToLine, Which = wdGoToFirst

    Application.ScreenUpdating = False

    ActiveDocument.Repaginate
    MyPages = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)

    DocFile = ActiveDocument.FullName
    intPos = InStrRev(DocFile, ".")
    MyName = Left(DocFile, intPos - 1)

    If Not fso.folderexists(MyName) Then
        fso.createfolder (MyName)
        FilePath = MyName
    Else
        FilePath = MyName
    End If

    x = 0
    'MsgBox MyPages
    For i = 0 To MyPages Step PartStep

        If i >= MyPages - PartStep Then
            s = e + 1
            e = MyPages
        Else
            s = i
            e = i + (PartStep - 1)
        End If
        'MsgBox (i & " | " & s & " | " & e)
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, count:=s
        Set rgePages = Selection.Range
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, count:=e
        rgePages.End = Selection.Bookmarks("\Page").Range.End
        rgePages.Select
        Selection.Copy
        x = x + 1

        Set objDoc = Documents.Add
        Selection.GoTo What = wdGoToLine, Which = wdGoToFirst
        Selection.PasteAndFormat (wdFormatOriginalFormatting)

        DocName = FilePath & "/" & "part" & Format(x, "000") & ".docx"
        ActiveDocument.SaveAs2 FileName:=DocName, _
                 FileFormat:=wdFormatXMLDocument, _
                 CompatibilityMode:=14

        ActiveDocument.Close savechanges:=wdDoNotSaveChanges
    Next i

    Set objDoc = Documents.Add
    DocName = FilePath & "/" & "Merg" & ".docx"
        ActiveDocument.SaveAs2 FileName:=DocName, _
                 FileFormat:=wdFormatXMLDocument, _
                 CompatibilityMode:=14
    ActiveDocument.Close savechanges:=wdDoNotSaveChanges

    Windows(1).Activate
    ActiveDocument.Close savechanges:=wdDoNotSaveChanges
    Dim oData   As New DataObject 'object to use the clipboard
    oData.SetText Text:=Empty 'Clear
    oData.PutInClipboard 'take in the clipboard to empty it
    Application.Quit
End Sub
sub test()
  Call Spliter(50)
end sub