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.