Creating Multiple Documents from a Single Documents

[Tom Burgan]

I have an .RTF document containing a TOC and roughly 200 pages or
reports. The TOC contains the 200 line-items (i.e. Heading 1) linking
to the 200 reports. I have been asked to separate this one document
into 200 separate documents. Borrowing from a macro I found searching
this group (Sub BreakOnHeading), I have been able to complete 95% of
this task. The only thing I have left to do is to somehow give each
separate document a unique file name. Ideally, I would like this file
name to incorporate some of the text from the TOC line-items. The
current code, seen below, just adds a number to the name of the master
document to generate a subdocument name:

.SaveAs FileName:=sCurrentPath & "\" & sCurrentDocStripped & i

Note: The .RTF document was generated using SAS. As such, each
report consists of 3 tables: a Titles/Heading table, a Data table, and
a Footnotes table. The last row in the Titles/Heading table contains
the Heading 1-style text referenced in the TOC.

Any ideas you may have about generating more descriptive file names
would be greatly appreciated.

Thank you.

Tom

Sub ParseClinicActivityReport()

Dim sCurrentDoc As String
Dim sCurrentDocStripped As String
Dim sCurrentPath As String
Dim i As Integer
Dim iNumBookmarks As Integer
Dim rng1 As Range
Dim rng2 As Range
Dim prng1 As Range
Dim prng2 As Range

sCurrentDoc = ActiveDocument.Name
sCurrentDocStripped = Left(sCurrentDoc, Len(sCurrentDoc) - 4)
sCurrentPath = ActiveDocument.Path

ActiveDocument.Bookmarks.DefaultSorting = wdSortByLocation
iNumBookmarks = ActiveDocument.Bookmarks.Count

For i = 1 To iNumBookmarks

Set rng1 = ActiveDocument.Range.Bookmarks.Item(i).Range

rng1.Select

Set prng1 = ActiveDocument.Bookmarks("\Page").Range

If i + 1 <= iNumBookmarks Then
Set rng2 = ActiveDocument.Range.Bookmarks.Item(i + 1).Range

rng2.Select

Set prng2 = ActiveDocument.Bookmarks("\Page").Range

prng1.Start = prng1.Start + 1
prng1.End = prng2.Start - 1
Else: prng1.End = ActiveDocument.Range.End
End If

If prng1.Characters.Count > 1 Then
prng1.Select
Selection.Copy

Documents.Add
Selection.Paste

With ActiveDocument
.PageSetup.TopMargin = InchesToPoints(0.25)
.PageSetup.LeftMargin = InchesToPoints(0.25)
.PageSetup.BottomMargin = InchesToPoints(0.25)
.PageSetup.RightMargin = InchesToPoints(0.25)
.PageSetup.Gutter = InchesToPoints(0)
.PageSetup.GutterPos = wdGutterPosLeft
.PageSetup.Orientation = wdOrientLandscape
.PageSetup.HeaderDistance = InchesToPoints(0.5)
.PageSetup.FooterDistance = InchesToPoints(0.5)
.SaveAs FileName:=sCurrentPath & "\" &
sCurrentDocStripped & i
.Close
End With
Documents(sCurrentDoc).Activate
End If

Next i
Selection.Collapse wdCollapseEnd
MsgBox "Finished!", vbOKOnly

End Sub

 

[Tom Burgan]

My "Note:" lead me to the answer. Before doing the .SaveAs, I went to
the table containing the information I wanted to include in the
filename (Set myTable = ActiveDocument.Tables(1)) and pulled the text
out (sCurrentDocName = myTable.Cell(4,1).Range.Text)