How to transfer formatting when splitting a document into several documents using Word VBA?

Question

I've a Word macro that splits a document into smaller documents if a specific text appears. The document consists of several contracts. The chosen text appears at the end. I choose a storage location and rename every contract.

How can I transfer the formatting of the original document to the new document?

Sub SplitNotes(delim As String, strFilename As String)
    Dim doc As Document
    Dim arrNotes
    Dim I As Long
    Dim X As Long
    Dim Response As Integer
    Dim fileName As String
    Dim folderPath As String
    Dim dlg As FileDialog

    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    dlg.Title = "Select Folder to Save Files"
    If dlg.Show <> -1 Then
        MsgBox "No folder selected. Exiting..."
        Exit Sub
    Else
        folderPath = dlg.SelectedItems(1)
    End If

    arrNotes = Split(ActiveDocument.Range, delim)
    Response = MsgBox("This will split the document into " & UBound(arrNotes) + 1 & " sections. Do you wish to proceed?", 4)
    If Response = 7 Then Exit Sub
    For I = LBound(arrNotes) To UBound(arrNotes)
        If Trim(arrNotes(I)) <> "" Then
            X = X + 1
            fileName = InputBox("Enter a name for section " & X, "Section Name")
            If fileName = "" Then
                MsgBox "Section " & X & " will be skipped because no name was entered."
            Else
                Set doc = Documents.Add
                doc.Range = arrNotes(I)
                doc.SaveAs folderPath & "\" & fileName & ".docx"
                doc.Close True
            End If
        End If
    Next I
End Sub


Sub test()
    'delimiter & filename
    SplitNotes "(einfach in der Suche eingeben)", "Notes"
End Sub

Answer 1

This code splits the active Word document into parts using <End of Contract> as the delimiter. The split documents are saved in the current folder.

Please provide details if the document format is more complex than the example.

Sub SplitDocumentWithFind()
    Dim srcDoc As Document, startPos
    Dim splitText As String
    Dim outputPath As String
    Dim i As Integer
    Dim srchRange As Range
    Dim newDoc As Document
    Set srcDoc = ActiveDocument
    splitText = "<End of Contract>"
    outputPath = srcDoc.Path & "\"
    Set srchRange = srcDoc.Range
    i = 1
    startPos = 0
    Application.ScreenUpdating = False
    Do While srchRange.Find.Execute(findText:=splitText)
        srchRange.MoveEndUntil Chr(13)
        ' Save the text before the splitText as a new document
        Set newDoc = Documents.Add
        srcDoc.Range(startPos, srchRange.End).Copy
        newDoc.Range.Paste
        newDoc.SaveAs2 outputPath & "Contract_" & i & ".docx", wdFormatDocumentDefault
        newDoc.Close SaveChanges:=wdSaveChanges
        i = i + 1
        startPos = srchRange.End + 1
    Loop
    Application.ScreenUpdating = True
    MsgBox "Active document split into " & (i - 1) & " parts.", vbInformation
End Sub

EDIT: I was able add a *hyphenation into the new document like that:

 With ActiveDocument
                .HyphenationZone = InchesToPoints(0.05)
                .HyphenateCaps = True
                .AutoHyphenation = True
            End With

The problem is, that the hyphenation zone is greyed out in the original document, but i can't deactivate it in the new one. What could be the reason for that? I think it leads to a problem with a very small piece of text being pushed down to a new page in the new document.

Another problem is, that i have two headers at the end, that shouldn't be there, is it possible to delete them somehow?