Macro to split Word documents into one

Question

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

I would like to use a macro to automatically create about a dozen subdocuments based on certain rules (mainly the appearance of certain lines in each section).

Is it possible? What VBA features should I read? Does anyone know any code examples that are even remotely similar and that I can customize for my purposes?

thanks

Answer 1

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

First, you need to place the macro in 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 the document, consisting of several sections, into several documents in the C: \ Destination directory, and then close Word.

You can do this from the command line with:

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

To process all .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 

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

Divide the document document per page, for example, use 50 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