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

Question

Closed. This question needs to be more focused. It is not currently accepting answers.

---

想要改进此问题？通过编辑这篇文章来更新问题，使其仅关注一个问题。

8 年前已关闭。

Answer 1

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

首先，您需要将宏放入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

保存Normal.dotm 文件。

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

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

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

要处理目录中的所有 .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

Answer 2

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

Answer 3

按页面计数器拆分 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