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
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
