File name from document text

[GMC]

Hi,
I have an rtf document which containts multiple tables with a text heading
above each table.
What i want to achieve is to extract each table as a seperate file and have
it saved as the text name that exists above each table. Additionally i would
like to save the file into a pre-created template.
The code for extracting the files (as found on this forum) is as follows:

Sub DocExtract()
Dim iDoc As Integer ' number of dcouments
Dim dDc1 As Document ' active document
Dim dDc2 As Document ' new document
Dim rTmp As Range ' temporary range
Set dDc1 = ActiveDocument
For iDoc = 1 To dDc1.Tables.Count
Set rTmp = ActiveDocument.Tables(iDoc).Range
rTmp.Copy
Set dDc2 = Documents.Add(Visible:=False)
dDc2.Activate
Selection.Paste
dDc2.SaveAs "C:\Test\" & Format(iDoc, "000") & ".doc"
dDc2.Close
Next
Set dDc1 = Nothing
Set dDc2 = Nothing
End Sub

Need to modify this to deal with the required steps. Hoping someone is able
to offer some assistance.

Thanks

 

[Helmut Weber]

Hi GMC,

I have an rtf document which containts multiple tables
with a text heading above each table.

is that the text of the paragraph preceding the table?

Additionally i would
like to save the file into a pre-created template.

That would be:
Set dDc2 = Documents.Add _
(Template:="c:\EditXP\myTemplate.dot", Visible:=False)

--

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Vista Small Business, Office XP

 

[GMC]

Hi Helmut
The text is preceding the table in the format of [41-200] etc.
Thanks for the solution to save to the template.

 

[Helmut Weber]

Hi GMC,

perhaps like that:

Sub DocExtract3()
Dim iDoc As Integer ' number of dcouments
Dim dDc1 As Document ' active document
Dim dDc2 As Document ' new document
Dim rTmp As Range ' temporary range
Dim sTmp As String ' text of paragraph preceding table
Set dDc1 = ActiveDocument
For iDoc = 1 To dDc1.Tables.Count
Set rTmp = ActiveDocument.Tables(iDoc).Range
sTmp = rTmp.Paragraphs.First.Previous.Range.Text
sTmp = Left(sTmp, Len(sTmp) - 1) ' cut off paragraph mark
rTmp.Copy
Set dDc2 = Documents.Add _
(Template:="c:\EditXP\myTemplate.dot", Visible:=False)
dDc2.Activate
Selection.Paste
' dDc2.SaveAs "C:\Test\" & Format(iDoc, "000") & ".doc"
dDc2.SaveAs "C:\Test\" & sTmp & ".doc"
dDc2.Close
Next
Set dDc1 = Nothing
Set dDc2 = Nothing
End Sub

--

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Vista Small Business, Office XP