Diaz,
I'll let you choose your friends :-),
I was bored and thought I would try to work this out.
Using this format:
This is the beginning. Beginning///
This is the body. Body///
This is the end. End
The following should work without extra empty files and copy formatting:
Sub test()
SplitNotes "///"
End Sub
Sub SplitNotes(strDelimiter As String)
Dim oThisDoc As Document
Dim oDoc As Document
Dim arrNotes() As String, arrTitles() As String
Dim lngIndex As Long, lngNum As Long, lngStart As Long
Dim strTitle As String
Dim oRng As Word.Range
Set oThisDoc = ActiveDocument
arrNotes = Split(ActiveDocument.Range, strDelimiter)
For lngIndex = 0 To UBound(arrNotes)
ReDim Preserve arrTitles(lngIndex)
arrTitles(lngIndex) = Right(arrNotes(lngIndex), Len(arrNotes(lngIndex)) - InStrRev(arrNotes(lngIndex), " ")) & "///"
Next lngIndex
If MsgBox("This will split the document into " & UBound(arrNotes) + 1 & " sections. Do you wish to proceed?", vbYesNo) = vbNo Then Exit Sub
For lngIndex = LBound(arrTitles) To UBound(arrTitles)
Select Case True
Case lngIndex = 0
Set oRng = oThisDoc.Range
With oRng.Find
.Text = arrTitles(lngIndex)
If .Execute Then
oRng.Start = oThisDoc.Range.Start
oRng.Select
lngStart = oRng.End
For lngNum = 1 To Len(arrTitles(lngIndex)) + 1
oRng.End = oRng.End - 1
Next
End If
End With
Case lngIndex = UBound(arrTitles)
Set oRng = oThisDoc.Range
oRng.Start = lngStart
lngStart = oRng.End
For lngNum = 1 To Len(arrTitles(lngIndex)) - 2
oRng.End = oRng.End - 1
Next
oRng.Select
If oRng.Characters.First = vbCr Then oRng.Start = oRng.Start + 1
oRng.Select
Case Else
Set oRng = oThisDoc.Range
oRng.Start = lngStart
With oRng.Find
.Text = arrTitles(lngIndex)
If .Execute Then
oRng.Start = lngStart
lngStart = oRng.End
For lngNum = 1 To Len(arrTitles(lngIndex)) + 1
oRng.End = oRng.End - 1
Next
If oRng.Characters.First = vbCr Then oRng.Start = oRng.Start + 1
End If
End With
End Select
oRng.Copy
Set oDoc = Documents.Add(ActiveDocument.AttachedTemplate.FullName)
oDoc.Content.Delete 'Strip template boiler plate text
oDoc.Range.PasteAndFormat (wdFormatOriginalFormatting)
strTitle = Replace(arrTitles(lngIndex), "///", "")
strTitle = Replace(strTitle, vbCr, "")
On Error GoTo Err_Save
oDoc.SaveAs ThisDocument.Path & "\" & strTitle
oDoc.Close True
Next lngIndex
lbl_Exit:
Exit Sub
Err_Save:
MsgBox Err.Number & " " & Err.Description
Resume lbl_Exit
End Sub