I have the following macro that splits a mail merge result at the starting text for each iteration. (I use start text and not section break as the document already has multiple section breaks, so this condition will not work.)
Anyways, the macro below works great except that when it adds a new document and pastes the data, the document structure is slightly out as line spacing is different and one or two other small details.
I was thinking if it was not possible to instead of opening a new document and copying to it, to rather save a copy of the original first and then delete data before and after the find variables? In other words, it will enable one to keep the styles and formatting of the original document for each duplication, preserving the data for that iteration with the exact styling and formatting.
Is it possible to tweak this macro to do this?
Code: Select all
Sub RunSplitDoc()
Dim docS As Document
Dim docT As Document
Dim myFind As String
Dim i As Long
Dim lngStart As Long
Dim lngEnd As Long
Dim wdDoc As Word.Document
Dim FileName As String
Dim PointPos As Long
Selection.HomeKey Unit:=wdStory
myFind = InputBox("Supply the text string to find that indicates " & _
"where the document must be split.", "Split Position")
If myFind = "" Then
Exit Sub
End If
Application.ScreenUpdating = False
Set docS = ActiveDocument
' Get name of source document
FileName = docS.Name
' Get position of last . in file name
PointPos = InStrRev(FileName, ".")
' Extract part before the point
FileName = Left(FileName, PointPos - 1)
i = -1
Selection.HomeKey Unit:=wdStory
With Selection.Find
.ClearFormatting
.Text = myFind
.Wrap = wdFindStop
Do While .Execute
i = i + 1
lngStart = lngEnd
lngEnd = Selection.Start
If i > 0 Then
Set docT = Documents.Add
docS.Range(Start:=lngStart, End:=lngEnd).Copy
docT.Content.Paste
' Use original file name + suffix
docT.SaveAs FileName:=docS.Path & "\" & FileName & Format(i, " 000")
docT.Close
End If
Loop
End With
i = i + 1
lngStart = lngEnd
lngEnd = docS.Content.End
Set docT = Documents.Add
docS.Range(Start:=lngStart, End:=lngEnd).Copy
docT.Content.Paste
' Use original file name + suffix
docT.SaveAs FileName:=docS.Path & "\" & FileName & Format(i, " 000")
docT.Close
Selection.HomeKey Unit:=wdStory
Application.ScreenUpdating = True
MsgBox "Data splitting is complete. The split documents are in the same " & _
"place as this current document.", vbInformation
End Sub
