Need macro to split large word doc by headings

[Philkp]

I have a large word doc (220 pages) that has several heading levels in it.
The need is to be able to split the doc into smaller documents for each Heading 1 , Heading 2

So say I have the following structure

1
1.1
text
1.2
text
1.3
text
2
2.1
text
2.2
text
3
3.1
text

Note that each of my heading 1 sections does not have any text directly under it.
Also each Heading 1, Heading 2 etc begin on a new page in my large doc, which means that the first page has only the heading 1 title for Section 1 and nothing else in it.

Can anyone please help here with a macro I can use to split this doc?
See attached doc.

[fumei]

It would be MUCH easier if the document used whatr Word considers Sections.

"my heading 1 sections"

You are refering to what is in your mind, not what Word considers Sections. There is only 1 Section in the document. One.

You need to be a bit more specific. What - exactly - does this mean?

"The need is to be able to split the doc into smaller documents for each Heading 1 , Heading 2"

Taking your example:
1
1.1
text
1.2
text
1.3
text
2
2.1
text
2.2
text
3
3.1
text


Does that mean you want:

SEPARATE DOCUMENT:
1

SEPARATE DOCUMENT:
1.1
text

SEPARATE DOCUMENT:
1.2
text

SEPARATE DOCUMENT:
1.3
text

SEPARATE DOCUMENT:
2

SEPARATE DOCUMENT:
2.1
text

SEPARATE DOCUMENT:
2.2
text

SEPARATE DOCUMENT:
3

SEPARATE DOCUMENT:
3.1
text

That is what "split the doc into smaller documents for each Heading 1 , Heading 2" actually states. But do you actually, really, mean:

SEPARATE DOCUMENT:
1
1.1
text
1.2
text
1.3
text

SEPARATE DOCUMENT:
2
2.1
text
2.2
text

SEPARATE DOCUMENT:
3
3.1
text

The 1, 2, 3 - as you point out - have no text really. It seems odd to make a separate document, thus I suspect you want your Heading 1 included with some document...but with each 1.2, 1.3 etc? In other words, do you want the heading text repeated for each Heading 2 document? That gets a little trickier.

Start with being very very specific.

BTW: you do not need to post the whole document. A sample up to, say, 3.1 would have been sufficient.

Again, if the document was structured using real Word Sections this would be very easy to do. As it is, I am sure it can be done, but it will take a wee bit of fussing. But you need to be very specific.

[Philkp]

Hi fumei,
Thank you for your response. This is exactly what I am looking for, as you mentioned. Unfortunately, I have no control over the doc (meaning I am not the author per-se) so I cannot get it done in sections, I am simply a consumer of this doc and I need to break it up into seperate docs for each Heading 1 (even though it has no text) and seperate docs for each Heading 2, exactly as shown in the example below

[quote=fumei]Does that mean you want:

SEPARATE DOCUMENT:
1

SEPARATE DOCUMENT:
1.1
text

SEPARATE DOCUMENT:
1.2
text

SEPARATE DOCUMENT:
1.3
text

SEPARATE DOCUMENT:
2

SEPARATE DOCUMENT:
2.1
text

SEPARATE DOCUMENT:
2.2
text

SEPARATE DOCUMENT:
3

SEPARATE DOCUMENT:
3.1
text

That is what "split the doc into smaller documents for each Heading 1 , Heading 2" actually states. quote]

[Philkp]

Here is some code I found on the net, but it does not work properly with my doc posted in the initial posting for some reason, if anyone can crack the issue that would be great


Sub Split_Hdr2()

Dim TotalLines As Long
Dim X As Long
Dim Groups() As Long
Dim Counter As Long
Dim y As Long
Dim FilePath As String
Dim FileName() As String

FilePath = ActiveDocument.Path
Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=1
Do
TotalLines = Selection.Range.Information(wdFirstCharacterLineNumber)
Selection.MoveDown Unit:=wdLine, Count:=1
Loop While TotalLines <> Selection.Range.Information(wdFirstCharacterLineNumber)
Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=1
For X = 1 To TotalLines
If Selection.Style = "Heading 2" Then
Counter = Counter + 1
ReDim Preserve Groups(1 To Counter)
ReDim Preserve FileName(1 To Counter)
Groups(Counter) = X
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
FileName(Counter) = Selection.Text
FileName(Counter) = Left(Selection.Text, Len(FileName(Counter)) - 1)
Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
End If
Selection.MoveDown Unit:=wdLine, Count:=1
Next
Counter = Counter + 1
ReDim Preserve Groups(1 To Counter)
Groups(Counter) = TotalLines

For X = 1 To UBound(Groups) - 1
y = Groups(X + 1) - Groups(X)
Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=Groups(X)
Selection.MoveDown Unit:=wdLine, Count:=y, Extend:=wdExtend
Selection.Copy
Documents.Add
Selection.Paste
ActiveDocument.SaveAs FilePath & "\" & FileName(X) & ".doc"
ActiveDocument.Close
Next X

End Sub

[fumei]

I have succeeded in doing what I think you want. Here is the logic.

1. find each Heading 1 and put a section break BEFORE it.
2. delete Section 1, as it is a new Section BEFORE the first Heading 1 (and thus is empty)
3. extract each Section into a TEMP doc
4. in the TEMP doc, get the text of the first paragraph (the Heading 1 text)
5. find each Heading 2, and put a section break BEFORE it
6. delete Section 1 (with the Heading 1 text - now in a string variable)

Pause: to be clear, what has happened so far is a TEMP doc with separate Sections for 1.1, 1.2, 1,3 ....1.x. OK?

7. for each Section in TEMP doc (1.1, 1.2, 1.3.....1.x) make a new document, and put that Section into it.

8. add the string of the original Heading 1 to the start of each doc

9. get the numbering string of the first paragraph (Heading 1, i.e. "1.1", "1.3" etc.) and use that for a filename SaveAs.

Thus:

NewDoc: "yadda_1.1.doc"
1 (text)
1.1
text

NewDoc: "yadda_1.2.doc"
1 (text)
1.2
text

NewDoc: "yadda_1.3.doc"
1 (text)
1.3
text

[fumei]

Regarding the code you posted....
Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=1
Do
TotalLines = Selection.Range.Information(wdFirstCharacterLineNumber)
Selection.MoveDown Unit:=wdLine, Count:=1
Loop While TotalLines <> Selection.Range.Information(wdFirstCharacterLineNumber)
this is truly bizarre coding! CRAZY!

[Philkp]

this makes absolute sense from a logic perspective and should hopefully be able to get me what I am looking for.
I am fairly new to VB so any chance this is something you could pass on code for me ? truely appreciate the tonne of help fumei


I have succeeded in doing what I think you want. Here is the logic.

1. find each Heading 1 and put a section break BEFORE it.
2. delete Section 1, as it is a new Section BEFORE the first Heading 1 (and thus is empty)
3. extract each Section into a TEMP doc
4. in the TEMP doc, get the text of the first paragraph (the Heading 1 text)
5. find each Heading 2, and put a section break BEFORE it
6. delete Section 1 (with the Heading 1 text - now in a string variable)

Pause: to be clear, what has happened so far is a TEMP doc with separate Sections for 1.1, 1.2, 1,3 ....1.x. OK?

7. for each Section in TEMP doc (1.1, 1.2, 1.3.....1.x) make a new document, and put that Section into it.

8. add the string of the original Heading 1 to the start of each doc

9. get the numbering string of the first paragraph (Heading 1, i.e. "1.1", "1.3" etc.) and use that for a filename SaveAs.

Thus:

NewDoc: "yadda_1.1.doc"
1 (text)
1.1
text

NewDoc: "yadda_1.2.doc"
1 (text)
1.2
text

NewDoc: "yadda_1.3.doc"
1 (text)
1.3
text

[fumei]

Ok, but that does NOT do what you said you wanted.

You want:

1 - separate doc

1.1 separate doc (WITHOUT the text of 1)

1.2 separate doc (WITHOUT the text of 1)

1.3 separate doc (WITHOUT the text of 1)

etc.

My code does:


NO separate doc of 1

1.1 separate doc (WITH the text of 1)

1.2 separate doc (WITH the text of 1)

1.3 separate doc (WITH the text of 1)

etc.

1. I will say it again. Be very specific. Tell me - EXACTLY, PRECISELY - what you are trying to do.

2. Using the logic I posted, have you tried anything yourself? Recording a macro perhaps?

[Philkp]

Hi fumei

Here is what I am looking to achieve

1 - separate doc

1.1 separate doc (WITHOUT the text of 1)

1.2 separate doc (WITHOUT the text of 1)

1.3 separate doc (WITHOUT the text of 1)

2 - separate doc

2.1 separate doc (WITHOUT the text of 2)

2.2 separate doc (WITHOUT the text of 2)

2.3 separate doc (WITHOUT the text of 2)

and so on.

[fumei]

Ok. Then we change the logic a wee bit.


1. find each Heading 1 and put a section break BEFORE it.

Result: 1, 1.1, 1.2.....1.x all in ONE Section, 2, 2.1, 2.2....2.x all in ONE Section.

2. extract each Section into a TEMP doc

Result: a new TEMP document of 1, 1.1, 1.2, 1.3....1.x

3. find each Heading 2, and put a section break BEFORE it

Result: Section = 1, Section 2 = 1.1, Section 3 = 1.2.....Section x = 1.x

Still with me?

4. extract each Section (of the TEMP doc) into a new document. You probably do not know how to do this, and since it does a have a non-intuitive wee (but important) point:
Sub ExtractEachSection()
Dim r As Range
Dim oSection As Section

For Each oSection In TEMPDoc.Sections
' assuming we are working with a temp doc object
' make range object THAT Section range
Set r = oSection.Range
' move it back one character to NOT include Section break
r.MoveEnd Unit:=wdCharacter, Count:=-1
' make new document
Documents.Add
' make new document range = current section range
ActiveDocument.Range = r
' save new doc
ActiveDocument SaveAs Filename:=??????????
ActiveDocument.Close
Next
End Sub
It is that truncating of the Section break that is significant.

I want to say welcome to the forum, and I want to say again, that it is important that you really think things out, and state what it is you want to do EXACTLY, PRECISELY.

You say you want a bunch of new documents. Fine. How do you want to name them? Where do you want to put them? In the same folder as the original doc? Someplace else?

BTW: you did not answer the question about if you have tried anything, like recording a macro. I want to be very clear that this is not a place to get off-the-shelf solutions. We are not a Help Desk, nor a solution centre. We are here to help people learn, to understand, not to hand out complete solutions. I know you are a beginner. We all were at one time. So I am going to post an almost solution for you. But you must understand that the point of this forum is for YOU to gain knowledge, and therefore YOU need to work at it.

Your solution will be something like:
Option Explicit

Sub SeparateHeadings()
Dim oPara As Paragraph
Dim r As Range
' break into 1.... and 2.... sections
For Each oPara In ActiveDocument.Paragraphs
If oPara.Style = "Heading 1" Then
Set r = oPara.Range
With r
.Collapse 1
.InsertBreak Type:=wdSectionBreakContinuous
End With
End If
Next

' break THOSE sections into 1.1, 1.2....
For Each oPara In ActiveDocument.Paragraphs
If oPara.Style = "Heading 2" Then
Set r = oPara.Range
With r
.Collapse 1
.InsertBreak Type:=wdSectionBreakContinuous
End With
End If
Next
End Sub

Sub EachSectionToDoc()
Dim oSection As Section
Dim TEMPDoc As Document
Dim r As Range

For Each oSection In ActiveDocument.Sections
' make range object THAT Section range
Set r = oSection.Range
' move it back one character to NOT include Section break
r.MoveEnd Unit:=wdCharacter, Count:=-1
' make new document
Set TEMPDoc = Documents.Add
' make new document range = current section range
TEMPDoc.Range = r
' save new doc
Tempdoc.SaveAs Filename:=??????????
TEMPDoc.Close
Set TEMPDoc = Nothing
Next
End Sub

Sub LetsDoIt()
Call SeparateHeadings
Call EachSectionToDoc
End Sub
Note that the SaveAs for each document is NOT complete...as you did not state what you want to do.

[Tinbendr]

Here's my effort. It separates the file by looking for the Style "Heading 1".
Sub ParseFileByHeading()
Dim aDoc As Document
Dim bDoc As Document
Dim Rng As Range
Dim Rng1 As Range
Dim Rng2 As Range
Dim Counter As Long
Dim Ans$

Ans$ = InputBox("Enter Filename", "Incremental number added")
If Ans$ <> "" Then

Set aDoc = ActiveDocument
Set Rng1 = aDoc.Range
Set Rng2 = Rng1.Duplicate

Do
With Rng1.Find
.ClearFormatting
.MatchWildcards = False
.Forward = True
.Format = True
.Style = "Heading 1"
.Execute
End With

If Rng1.Find.Found Then
Counter = Counter + 1
Rng2.Start = Rng1.End + 1
With Rng2.Find
.ClearFormatting
.MatchWildcards = False
.Forward = True
.Format = True
.Style = "Heading 1"
.Execute
End With

If Rng2.Find.Found Then
Rng2.Select
Rng2.Collapse wdCollapseEnd
Rng2.MoveEnd wdParagraph, -1
Set Rng = aDoc.Range(Rng1.Start, Rng2.End)
Set bDoc = Documents.Add
bDoc.Content.FormattedText = Rng

bDoc.SaveAs Ans$ & Counter, wdFormatDocument
bDoc.Close
Else
'This collects from the last Heading 1
'to the end of the document.
If Rng2.End < aDoc.Range.End Then
Set bDoc = Documents.Add
Rng2.Collapse wdCollapseEnd
Rng2.MoveEnd wdParagraph, -2
Set Rng = aDoc.Range(Rng2.Start, aDoc.Range.End)
bDoc.Content.FormattedText = Rng
bDoc.SaveAs Ans$ & Counter, wdFormatDocument
bDoc.Close
End If
End If
End If

Loop Until Not Rng1.Find.Found

'This is closing End If from Ans$
End If
End Sub I did run into one anomaly though. Section four header wasn't formatted properly, so it kept lumping three and four together. Once I reformatted the header to include the whole line, it worked as expected.

Cheers,
David

[new23]

Tinbendr,

Your macro works fine on my word -2007.
Thanks !!!:clap:

But, is it possible - every new file to have a name exactly - as the text in headings style, instead text I typed in box .

I`m using serbian Latin in text.

Thanks
Ivan
:beerchug:






Here's my effort. It separates the file by looking for the Style "Heading 1".
Sub ParseFileByHeading()
Dim aDoc As Document
Dim bDoc As Document
Dim Rng As Range
Dim Rng1 As Range
Dim Rng2 As Range
Dim Counter As Long
Dim Ans$

Ans$ = InputBox("Enter Filename", "Incremental number added")
If Ans$ <> "" Then

Set aDoc = ActiveDocument
Set Rng1 = aDoc.Range
Set Rng2 = Rng1.Duplicate

Do
With Rng1.Find
.ClearFormatting
.MatchWildcards = False
.Forward = True
.Format = True
.Style = "Heading 1"
.Execute
End With

If Rng1.Find.Found Then
Counter = Counter + 1
Rng2.Start = Rng1.End + 1
With Rng2.Find
.ClearFormatting
.MatchWildcards = False
.Forward = True
.Format = True
.Style = "Heading 1"
.Execute
End With

If Rng2.Find.Found Then
Rng2.Select
Rng2.Collapse wdCollapseEnd
Rng2.MoveEnd wdParagraph, -1
Set Rng = aDoc.Range(Rng1.Start, Rng2.End)
Set bDoc = Documents.Add
bDoc.Content.FormattedText = Rng

bDoc.SaveAs Ans$ & Counter, wdFormatDocument
bDoc.Close
Else
'This collects from the last Heading 1
'to the end of the document.
If Rng2.End < aDoc.Range.End Then
Set bDoc = Documents.Add
Rng2.Collapse wdCollapseEnd
Rng2.MoveEnd wdParagraph, -2
Set Rng = aDoc.Range(Rng2.Start, aDoc.Range.End)
bDoc.Content.FormattedText = Rng
bDoc.SaveAs Ans$ & Counter, wdFormatDocument
bDoc.Close
End If
End If
End If

Loop Until Not Rng1.Find.Found

'This is closing End If from Ans$
End If
End Sub I did run into one anomaly though. Section four header wasn't formatted properly, so it kept lumping three and four together. Once I reformatted the header to include the whole line, it worked as expected.

Cheers,
David

[Tinbendr]

But, is it possible - every new file to have a name exactly - as the text in headings style, instead text I typed in box .

I`m using serbian Latin in text.It should look for 'Heading 1' (which is a style name) no matter what the font name.

If you asking to split the document based on font name, then we'll have to adjust it.

[new23]

4544[/ATTACH]
It should look for 'Heading 1' (which is a style name) no matter what the font name.

If you asking to split the document based on font name, then we'll have to adjust it.

I`m having a list of exam questions in word document, and formated tham as heading1.

The name of exam is "Ustav" ...means Constitusion (law -bar exam)
I`ll attach document...so U can see it.

I typed "Ustavno" in macro input box, ( "incremental number added" - b.t.w. don`t know meaning,.....enter file name....... and result were separate files named like "Ustavno1, Ustavno2, Ustavno 3.....etc)

I was expecting output separate files to be exactly named like headings are ...

First file- "68. Pravo na rehabilitaciju i naknadu štete" and text below in no spacing style .....second file "81. Prava pripadnika nacionalnih manjina"...and text below in no spacing style....third file - "82. Pravo na očuvanje posebnosti" ...and text below ( in no spacing style)....etc

Thanks again, and sorry for taking Your time.

Best regards

Ivan

[Tinbendr]

I was expecting output separate files to be exactly named like headings are ...
I understand now.

I think I have it working now. Attached is the new version.

Run the one in module 1, not module 2.

David

[new23]

I understand now.

I think I have it working now. Attached is the new version.

Run the one in module 1, not module 2.

David

It doesn`t work
Here is image -after run module1
Or I`m doing something wrong..
Ivan

[Tinbendr]

There are two O's in Option Explicit. Take one out.

[new23]

It Works!
Thanks!
Ivan

[gentle]

Hi


I have taken the two macros that where submitted by Tinbendr and joined them .
(used the sample named exam TM.doc )


The results is now that when the output files are saved they will be marked with a number in the front and then the "heading 1" keeping it in the same order that was in the original document.

The only difference is you have to put a word at the bottom of your original document eg..END and also make it a “header 1”. (this is to get the last one to be added)

The document will be names as follows :
2 _ 68. Pravo na rehabilitaciju i naknadu štete
3 _ 81. Prava pripadnika nacionalnih manjina
4 _ 82. Pravo na očuvanje posebnosti


Run the one in module 3 for .doc
And module 4 if you want rtf.




Sub ParseFileByHeadingSaveDoc()

Dim aDoc As Document
Dim bDoc As Document
Dim Rng As Range
Dim Rng1 As Range
Dim Rng2 As Range
Dim Counter As Long
Dim Ans$

'Ans$ = InputBox("Enter Filename", "Incremental number added")
'If Ans$ <> "" Then

Set aDoc = ActiveDocument
Set Rng1 = aDoc.Range
Set Rng2 = Rng1.Duplicate

Do
With Rng1.Find
.ClearFormatting
.MatchWildcards = False
.Forward = True
.Format = True
.Style = "Heading 1"
.Execute
End With

If Rng1.Find.Found Then
Ans$ = Rng1.Text
Counter = Counter + 1
Rng2.Start = Rng1.End + 1
With Rng2.Find
.ClearFormatting
.MatchWildcards = False
.Forward = True
.Format = True
.Style = "Heading 1"
.Execute
End With

If Rng2.Find.Found Then
Rng2.Select
Rng2.Collapse wdCollapseEnd
Rng2.MoveEnd wdParagraph, -1
Set Rng = aDoc.Range(Rng1.Start, Rng2.End)
Set bDoc = Documents.Add
bDoc.Content.FormattedText = Rng

If Ans$ <> "" Then
bDoc.SaveAs Counter + 1 & " _ " & Left(Ans$, Len(Ans$) - 2) & ".doc", wdFormatDocument
'bDoc.SaveAs Ans$ & Counter, wdFormatDocument
bDoc.Close
Else
'This collects from the last Heading 1
'to the end of the document.
If Rng2.End < aDoc.Range.End Then
Set bDoc = Documents.Add
Rng2.Collapse wdCollapseEnd
Rng2.MoveEnd wdParagraph, -2
Set Rng = aDoc.Range(Rng2.Start, aDoc.Range.End)
bDoc.Content.FormattedText = Rng

If Ans$ <> "" Then
bDoc.SaveAs Counter + 1 & " _ " & Left(Ans$, Len(Ans$) - 2) & ".doc", wdFormatDocument
'bDoc.SaveAs Ans$ & Counter, wdFormatDocument
bDoc.Close
End If
End If
End If
End If
End If

Loop Until Not Rng1.Find.Found

'This is closing End If from Ans$

End Sub

Sample has been renamed.


Thank you for the info that was posted by all.
I was able to get an answer to my own question posted.
:clap:

[new23]

"Run the one in module 3 for .doc And module 4 if you want rtf."

It works too.

(and module 4 for .html and module 5 for .one and module 6 for .pdf ? ):thumb

[marsh]

"The results is now that when the output files are saved they will be marked with a number in the front and then the "heading 1" keeping it in the same order that was in the original document.

The only difference is you have to put a word at the bottom of your original document eg..END and also make it a “header 1”. (this is to get the last one to be added)"


Hi Gentle

Iam not able to add the last section of the document when i split the document using headings though i put sample word at the end of the original document. Pls help and thank you in advance.

Regards
marsh

[marsh]

Hi Tinbendr,

Can you pls attach the new version of code which you attached to Ivan

Thank you,
Marsh

[nappi90]

Hey,

im trying to get a code that splits a large document in several doc.files and saves them automatically.

SEPARATE DOCUMENT:
1
text

SEPARATE DOCUMENT:
1.1
text

SEPARATE DOCUMENT:
1.2
text

SEPARATE DOCUMENT:
2
text

SEPARATE DOCUMENT:
2.1
text

and so on.




Sub SplitHeadingLevel1()

Dim AppWD As Object
Dim rng As Word.Range
Dim sStyle As Word.Style
Dim aDoc As New Word.Document
Dim oDoc As New Word.Document

Set AppWD = CreateObject("Word.Application") 'Word als Object starten
AppWD.Documents.Open "C:\Users\VW2COZ6\Test\Documents\text.doc"
AppWD.Visible = False

Set aDoc = AppWD.ActiveDocument
Set rng = aDoc.Content
With rng.Find
.Style = wdStyleHeading1
.Execute
Do While .Found = True
rng.Select
rng.Bookmarks("\HeadingLevel").Range.Select
If Asc(Mid(rng.Text, 1, 1)) = 12 Then ' Manueller Seitenwechsel?
AppWD.Selection.Start = Selection.Start + 1
End If
AppWD.Selection.Copy
Set oDoc = Documents.Add
oDoc.Range.PasteSpecial
SplitHeadingLevel2 oDoc, AppWD
With Dialogs(wdDialogFileSaveAs)
.Name = ActiveDocument.Path & "\" & Left(rng.Paragraphs(1).Range.Text, _
Len(rng.Paragraphs(1).Range.Text) - 1)
.Show
End With
.Execute Forward:=True
Loop
End With
AppWD.Documents("C:\Users\VW2COZ6\Test\Documents\text.doc").Close SaveChanges:=False
AppWD.Quit

End Sub


Sub SplitHeadingLevel2(oDoc2 As Word.Document, AppWD As Object)

Dim rng2 As Word.Range
Dim oDoc As New Word.Document

Set rng2 = oDoc2.Content
With rng2.Find
.Style = wdStyleHeading2
.Execute
Do While .Found = True
rng2.Select
rng2.Bookmarks("\HeadingLevel").Range.Select
If Asc(Mid(rng2.Text, 1, 1)) = 12 Then ' Manueller Seitenwechsel?
AppWD.Selection.Start = Selection.Start + 1
End If
AppWD.Selection.Copy
Set oDoc = Documents.Add
oDoc.Range.PasteSpecial
With Dialogs(wdDialogFileSaveAs)
.Name = ActiveDocument.Path & "\" & Left(rng2.Paragraphs(1).Range.Text, _
Len(rng2.Paragraphs(1).Range.Text) - 1)
.Show
End With
.Execute Forward:=True
Loop
End With
End Sub


i was trying to write a sub SplitHeadingLevel1 that returns heading 1 like:

SEPARATE DOCUMENT:
1
text

and another sub SplitHeadingLevel2 that returns heading 2 that returns docs like:
SEPARATE DOCUMENT:
1.1
text

SEPARATE DOCUMENT:
1.2
text

but sub1 returns docs containing heading2

and i still havent managed to save the files automatically...
Would be nice if you could help me :D:)

[Apsis0215]

Wanted to put my 2 cents in 2 years later so I can find it again : )


Attribute VB_Name = "SPLIT_BY_HEADINGS"
Option Explicit


Sub SplitByPara()
Dim aDoc As Document
Dim bDoc As Document
Dim rng As Range


Dim fp As String
Dim fn As String

Dim Counter As Long
Dim Ans$

Dim para As Paragraph
Dim ParaLast As Paragraph

Dim i

Set aDoc = ActiveDocument

''Cread subfolder for paragraphs
If aDoc.Path > "" Then
On Error Resume Next
fp = aDoc.Path & "\" & aDoc.Name
VBA.MkDir (fp)
fp = fp & "\"
On Error GoTo 0
End If

Set ParaLast = aDoc.Paragraphs.Last

For i = aDoc.Paragraphs.Count - 1 To 1 Step -1 ''paras from next-to-last to first

Set para = aDoc.Paragraphs(i)

''If para.Style = "Heading 1" And para.Range.Text > "" Then
If Parastyles(para, Array("Heading 1*", "Heading 2*", "*Appendix*")) And para.Range.Text > "" Then

'Do While para.Style = "Heading 1" And I > 1 ''count in sequential headings
' I = I - 1
' Set para = ActiveDocument.Paragraphs(I)
'Loop

'''copy form para2 to para
Set rng = ActiveDocument.Range(para.Range.Start, ParaLast.Range.End)
rng.Expand Word.wdCollapseStart
'rng.MoveEnd wdParagraph, -2

fn = StrFormat(Format(i, "00000") & "-" & para.Range.ListFormat.ListString & "-" & Left(Trim(para.Range.Text), 64))

Set bDoc = Documents.Add
bDoc.Content.FormattedText = rng

On Error Resume Next
bDoc.SaveAs fp & fn, Word.wdFormatDocument
On Error GoTo 0
bDoc.Close False

End If
Next i
End Sub


Private Function Parastyles(para As Paragraph, strStyles) As Boolean
Dim i As Integer
Dim K As Integer

i = -1
On Error Resume Next
i = UBound(strStyles)
On Error GoTo 0

For K = 0 To i
If para.Style Like strStyles(K) Then
Parastyles = True
Exit Function
End If
Next K

End Function


Private Function StrFormat(strString As String) As String
Dim regex As New regexp

With regex
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "[^a-zA-Z0-9\-]"
End With

StrFormat = regex.Replace(strString, "-")


With regex
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "\-{1,}"
End With

StrFormat = regex.Replace(StrFormat, "-")
End Function

[Apsis0215]

Attribute VB_Name = "SPLIT_BY_HEADINGS"
Option Explicit

Sub SplitByPara()
Dim aDoc As Document
Dim bDoc As Document
Dim rng As Range

Const levels = 2

Dim FP As String
Dim fn As String

Dim Counter As Long
Dim Ans$

Dim para As Paragraph
Dim ParaLast As Paragraph

Dim I

Set aDoc = ActiveDocument

FP = aDoc.Path & "\" & StrFormat(aDoc.Name)

NewFolder FP

Set ParaLast = aDoc.Paragraphs.Last

For I = aDoc.Paragraphs.Count - 1 To 1 Step -1 ''paras from next-to-last to first

Set para = aDoc.Paragraphs(I)

''If para.Style = "Heading 1" And para.Range.Text > "" Then
If Parastyles(para, Array("Heading 1*", "Heading 2*", "*Appendix*")) And para.Range.Text > "" Then
'''copy form para2 to para

Set rng = ActiveDocument.Range(para.Range.Start, ParaLast.Range.Start)

fn = PadParanums(para.Range.ListFormat.ListLevelNumber, 2) & "-" & Left(Trim(para.Range.Text), 64)

fn = StrFormat(fn)

Set bDoc = Documents.Add
bDoc.Content.FormattedText = rng

On Error Resume Next
VBA.Kill FP & fn
bDoc.SaveAs FP & fn, Word.wdFormatDocument
On Error GoTo 0
bDoc.Close False

Set ParaLast = para
ParaLast.Range.MoveStart wdParagraph - 1
End If
Next I
End Sub

Private Function PadParanums(strString As String, Optional levels As Integer) As String '' add 0's in numbered formats
Dim x
Dim I, xI
strString = StrFormat(strString)
x = Split(strString, "-")
Const format = "000"
xI = -1

On Error Resume Next

xI = UBound(x)

On Error GoTo 0

For I = 0 To xI
If x(I) Like "*#*" Then
PadParanums = PadParanums & Right(format & x(I), 3) & "-"
End If
Next I
For I = UBound(Split(PadParanums, "-")) To levels - 1 ''use padparanums to determine number of levels defined then add padded 000- for remining
PadParanums = PadParanums & format & "-"
Next I
PadParanums = StrFormat(PadParanums)
End Function


Private Function Parastyles(para As Paragraph, strStyles) As Boolean
Dim I As Integer
Dim K As Integer

I = -1
On Error Resume Next
I = UBound(strStyles)
On Error GoTo 0

For K = 0 To I
If para.Style Like strStyles(K) Then
Parastyles = True
Exit Function
End If
Next K

End Function

Function StrFormat(strString As String) As String
Dim regex As New regexp

With regex
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "[^a-zA-Z0-9\-]"
End With

StrFormat = regex.Replace(strString, "-")

With regex
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "\-{1,}"
End With


StrFormat = regex.Replace(StrFormat, "-")

'''Remove trailing dashes
With regex
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "\-{1,}(?=\s|$)"
End With

StrFormat = regex.Replace(StrFormat, "")
End Function

Sub NewFolder(FP As String, Optional DoNotOpen As Boolean)
Dim OpenFold As Variant
Dim oShell As Object
Dim Wnd As Object
''Dim strFolder
''OpenFold = "mysubfolder"
''strFolder = "U:\myfolder\" & OpenFold

Set oShell = CreateObject("Shell.Application")

''Wnd.LocationName
''Cread subfolder for paragraphs

On Error Resume Next
VBA.MkDir (FP)
FP = FP & "\"
On Error GoTo 0


For Each Wnd In oShell.Windows
Debug.Print Wnd.Document.Folder.Self.Path
'' If Wnd.LocationName = "Windows Explorer" Then
If LCase(Wnd.Document.Folder.Self.Path & "\") = LCase(FP) Then
Wnd.Visible = True
Exit Sub
End If
''End If
Next Wnd

If Not DoNotOpen Then Shell "C:\WINDOWS\explorer.exe """ & FP & "", vbNormalFocus

End Sub