Macro for one-to-many splitting of Word documents [closed]

Want to improve this question? Update the question so it focuses on one problem only by editing this post.

I have a Word document which is several hundred pages long. 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? Thanks

3 Answers 3

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:

 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.

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.

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:

@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 

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 

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

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