Solved: Copy data between styles to new document

[jakesp]

I need to split up a large document according to a style that it finds, then save that portion of the document into a new file with the with actual text of the style that it found as the name of the file. I have include an example to help what I mean.

********* Large document ***********

HEADING 1
this is some text in the first part of the document

HEADING 2 this is some text in the second part of the document

HEADING 2 this is some text in the third part of the document

********* End of Large document ***********


The above needs to end up as follows:


********* Document 1 ***********

HEADING 1
this is some text in the first part of the document

********* Document 2 ***********

HEADING 2 this is some text in the second part of the document

********* Document 3 ***********

HEADING 2 this is some text in the third part of the document


Sorry its a bit of a tongue twister to explain what I mean

Thank you in advance...

[Killian]

Hi and welcome to VBAX :hi:

Below is some code that will do more or less what you ask. Just paste it into a module in the document that you want to process and run it. As it stands, the styles to search are defined in the code. You'll have to work out a way of tailoring it to your requirement - looping through all "Heading x" styles or maybe choosing them from a user form. Anyway, it should get you started'### Path to save split documents ###
Const myFolder As String = "C:\TEMP\"

'### Main routine ###
Sub SplitDocByStyle()

Dim SourceDoc As Document
Dim StartChar As Long, EndChar As Long
Dim rngSection As Range
Dim NewWdDoc As Document

Set SourceDoc = ActiveDocument
StartChar = GetStyleStartChar(SourceDoc, "Heading 1")
EndChar = GetStyleStartChar(SourceDoc, "Heading 2")
If StartChar <> -1 And EndChar <> -1 Then
Set rngSection = SourceDoc.Range(StartChar, EndChar)
Else
If StartChar = -1 Then
MsgBox "First style not in use"
Set SourceDoc = Nothing
Exit Sub
Else
MsgBox "Second style not in use"
Set SourceDoc = Nothing
Exit Sub
End If
End If
Set NewWdDoc = Application.Documents.Add
NewWdDoc.Content.Text = rngSection
NewWdDoc.SaveAs myFolder & GetNewFileName(SourceDoc, "Heading 1")
NewWdDoc.Close
Set NewWdDoc = Nothing
Set SourceDoc = Nothing

End Sub

'### Function to return character index at the start of a named style
Function GetStyleStartChar(doc As Document, StyleName As String) As Long

Dim myRange As Range

Set myRange = doc.Content
With myRange.Find
.ClearFormatting
.Style = doc.Styles(StyleName)
.Text = ""
.Forward = True
.Execute
If .Found = True Then
myRange.Collapse wdCollapseStart
GetStyleStartChar = myRange.Start
Else
GetStyleStartChar = -1
End If
End With
Set myRange = Nothing

End Function

'### Function to return text of a named style
Function GetNewFileName(doc As Document, StyleName As String) As String

Dim myRange As Range

Set myRange = doc.Content
With myRange.Find
.ClearFormatting
.Style = doc.Styles(StyleName)
.Text = ""
.Forward = True
.Execute
End With
GetNewFileName = Left(myRange.Text, Len(myRange.Text) - 1)
Set myRange = Nothing

End Function

[jakesp]

Thanks. I will give it a bash and get back to you.

Regards

I keep get a the following error "Word cannot complete the save due to a file permission error" on the following line:

NewWdDoc.SaveAs myFolder & GetNewFileName(SourceDoc, "Statement")

BTW - "Statement" is the heading style that Im working with

[Killian]

Strange... no such error when I run it. You should confirm that you have permission to write to the path you've set, though I would expect a slightly different error message.
There is also a known bug with Word2000 that produces this error is some cases that is fixed with SR1/1a.
Let me know if this doesn't help and we'll work out some tests to find the issue

[jakesp]

Sorry about that, its my MS Word that is playing up. I ran it on another machine and it worked great... thanks for the help!

Regards