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