Splitting document macro

[JPh]

To split a Word document in several files I'm using a code provided 4 years ago by gmaxey in the VBA Express thread "Split Document with delimiter and Name new file" (for some reason my post is denied if I link to it):

Sub test()
SplitNotes "///"
End Sub
Sub SplitNotes(strDelimiter As String)
Dim oDoc As Document
Dim arrNotes() As String, arrTitles() As String
Dim lngIndex As Long, lngNum As Long
Dim strTitle As String
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(arrNotes) To UBound(arrNotes)
If Trim(arrNotes(lngIndex)) <> "" Then
Set oDoc = Documents.Add
oDoc.Range = arrNotes(lngIndex)
On Error Resume Next
strTitle = arrTitles(lngIndex)
If Err.Number <> 0 Then
oDoc.SaveAs ThisDocument.Path & "\" & strTitle
Else
lngNum = lngNum + 1
oDoc.SaveAs ThisDocument.Path & "\" & "Misc " & Format(lngNum, "000")
End If
oDoc.Close True
End If
Next lngIndex
End Sub

It works well, prompting me for split file names. But, as mentioned at the time, it doesn't preserve formatting.

To address this issue, another, final code was provided in the aforementioned thread. This lengthier code, unfortunately, doesn't prompt for file names (in fact, running it, I don't even know where the split files landed).

It would be great to have both : a code that prompts for split file names and preserve formatting.

Thank you in advance,

Jean

[Kilroy]

I was using an array to replace page breaks. You only need to use from split2 forward. I left in as someone may find it useful. can anyone tell me why ^b causes errors now?

Sub Split1()
    Dim arr() As Variant
    Dim i As Byte
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    'arr = Array("^b", "^m", "^n")
    'Why Doesn't "^b" work anymore?
    arr = Array("QQQ")
    For i = LBound(arr) To UBound(arr)
        With Selection.Find
            .text = arr(i)
            .Replacement.text = "///"
            .Forward = True
            .Wrap = wdFindContinue
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
    Next
    Call Split2
End Sub
Sub Split2()
    SplitNotes "///"
End Sub
Sub SplitNotes(strDelimiter As String)
    Dim oDoc As Document
    Dim arrNotes() As String, arrTitles() As String
    Dim lngIndex As Long, lngNum As Long
    Dim strTitle As String
    Dim oRng As Word.range
    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(arrNotes) To UBound(arrNotes)
        If Trim(arrNotes(lngIndex)) <> "" Then
            Set oDoc = Documents.Add
            oDoc.range = arrNotes(lngIndex)
            On Error Resume Next
            strTitle = arrTitles(lngIndex)
            If Err.Number = 0 Then
                Set oRng = ActiveDocument.range
                oRng.Collapse wdCollapseEnd
                oRng.MoveStart wdWord, -1
                oRng.Delete
                oDoc.SaveAs2 ThisDocument.path & "\" & strTitle
            Else
                lngNum = lngNum + 1
                oDoc.SaveAs ThisDocument.path & "\" & "Misc " & Format(lngNum, "000")
            End If
            oDoc.Close True
        End If
    Next lngIndex
    
End Sub

[JPh]

Thanks but it's the same problem as before: formatting (italics, headings) is lost in the split files.

[gmaxey]

Sub test()
  SplitNotesX "///"
End Sub
Sub SplitNotesX(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) = "///"
  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)
  For lngIndex = LBound(arrNotes) To UBound(arrNotes)
    Select Case True
      Case lngIndex = 0
        Set oRng = oThisDoc.Range
        With oRng.Find
          .Text = strDelimiter
          If .Execute Then
            oRng.Start = oThisDoc.Range.Start
            oRng.Select
            lngStart = oRng.End
            For lngNum = 1 To Len(strDelimiter)
              oRng.End = oRng.End - 1
            Next
          End If
        End With
        oRng.Select
      Case lngIndex = UBound(arrTitles)
        Set oRng = oThisDoc.Range
        oRng.Start = lngStart
        lngStart = oRng.End
'        For lngNum = 1 To Len(strDelimiter)
'          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(strDelimiter)
              oRng.End = oRng.End - 1
            Next
            If oRng.Characters.First = vbCr Then oRng.Start = oRng.Start + 1
          End If
        End With
        oRng.Select
    End Select
    oRng.Copy
    Set oDoc = Documents.Add(ActiveDocument.AttachedTemplate.FullName)
    oDoc.Content.Delete 'Strip template boiler plate text
    oDoc.Range.PasteAndFormat (wdFormatOriginalFormatting)
    On Error GoTo Err_Save
    oDoc.SaveAs ThisDocument.Path & "\" & InputBox("Enter a file name", "Name")
    oDoc.Close True
  Next lngIndex
lbl_Exit:
  Exit Sub
Err_Save:
  MsgBox Err.Number & " " & Err.Description
  Resume lbl_Exit
End Sub

[JPh]

Thank you gmaxey. The new macro preserves formatting and prompts for file names. Unfortunately the files are stored in Appdata/Roaming/Microsoft/Template, which isn't very convenient. One would rather have them in the same directory as the original file, if that's possible (one would think the "oDoc.SaveAs ThisDocument.Path ..." line above should do that).

Update: I found it. Replacing "ThisDocument.Path" with "oThisDoc.Path" does it. So now everything's there. Thanks again.