Attached is a sample document that (in reality will be a few hundred pages long - system generated). The aim is to split at sections, which the code I have below does very effectively, but I need help with two small changes.
1. Each split document must be named (not with SplitDocSample_001) as currently in the code, BUT with the Personnel Number (just the number) in the table at the beginning of the doc. So I need to collect that number only and use in the save statement of the macro. Not sure how to do that?
2. When the section is pasted into a new document, it creates a blank page at the end. The code does delete the last section break, but as you can see, the section break is directly after the last bullet point, so deleting the break deletes the last bullet point too? How can this be avoided.
TIA for the assistance.
Code: Select all
Sub BreakOnSection()
Dim sBaseName As String, sNewFileName As String
Dim lSec As Long, lDocNum As Long
Dim sFilePath As String
Dim doc As Document
'Application.ScreenUpdating = False
With Application.FileDialog(1)
.Filters.Clear
.Filters.Add "Word documents", "*.doc*"
If .Show Then
sFilePath = .SelectedItems(1)
Else
MsgBox "No document specified!", vbExclamation
Exit Sub
End If
End With
On Error GoTo CopyFailed
Documents.Open sFilePath
Application.Browser.Target = wdBrowseSection
sBaseName = ActiveDocument.Name
For lSec = 1 To ActiveDocument.Sections.Count - 1
'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
' Removes the break that is copied at the end of the section, if any.
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
lDocNum = lDocNum + 1
sNewFileName = Replace(sBaseName, ".do", "_" & Format(lDocNum, "000") & ".do")
ActiveDocument.SaveAs ThisDocument.Path & "\" & sNewFileName
ActiveDocument.Close
' Move the selection to the next section in the document.
Application.Browser.Next
Next lSec
Documents(sBaseName).Close False
End
CopyFailed:
MsgBox "An unexpected error occured during processing!" & vbNewLine & _
Err.Description, vbExclamation
'Application.Quit SaveChanges:=wdSaveChanges
End
End Sub