Break a part a Word Documnet using VBA

[Jack]

I am using Word 2000 and would like to know if there is an easy way to break
a 100 page document up into 100 1 page documents and sequentially name the
resulting files. For example my document is called Fish and is 100 pages
long. I run a macro and then i have 100 documents each 1 page long called
Fish1, Fish 2 etc.

I did a search and found the following referring to breaking it up by
headings but my VBA is not good enough to adapt this -

Option Explicit

Sub SeperateHeadings()

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 1" 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

 

[Cindy M -WordMVP-]

Hi =?Utf-8?B?SmFjaw==?=,

I am using Word 2000 and would like to know if there is an easy way to break
a 100 page document up into 100 1 page documents and sequentially name the
resulting files. For example my document is called Fish and is 100 pages
long. I run a macro and then i have 100 documents each 1 page long called
Fish1, Fish 2 etc.

The fastest/easiest way, probably, would be to make sure the first paragraph of
each page (and only the first paragraph) is formatted using the Heading 1
style. You can then go into the Outline view and make the document a "Master
Document". Have it create sub-documents from the entire document, based on the
Heading 1, then loop through the sub documents and save them.

The basic code for this last part is on my website:

http://homepage.swissonline.ch/cindymeister/Mergfaq2.htm#SepFile

Cindy Meister
INTER-Solutions, Switzerland
http://homepage.swissonline.ch/cindymeister (last update Jun 8 2004)
http://www.word.mvps.org

This reply is posted in the Newsgroup; please post any follow question or reply
in the newsgroup and not by e-mail

 

[Helmut Weber]

Hi Jack,

there are numerous examples to be found,
though I haven't found a single one right now.
It's often better anway, to code it anew.
The code gets better with doing it all again, hopefully.

Like this:

Sub Dunno11()
Dim l As Long ' just a counter
Dim lPgs As Long ' number of pages
Dim Newdoc As Document
Dim OldDoc As Document
Application.ScreenUpdating = False
Set OldDoc = ActiveDocument
lPgs = OldDoc.BuiltInDocumentProperties(wdPropertyPages)
For l = 1 To lPgs
Set Newdoc = Documents.Add(Visible:=False)
OldDoc.Activate
Selection.GoTo what:=wdGoToPage, _
which:=wdGoToAbsolute, _
Count:=l
Selection.Bookmarks("\page").Select
Newdoc.Range = Selection.Range
Newdoc.SaveAs "c:\000\fish-" & Format(l, "000") & ".doc"
Newdoc.Close
Next
Set Newdoc = Nothing
End Sub
--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Jack]

Helmut you're a genius! This is almost there. The only problem is that the
document that it saves have a blank page at the end, so my 1 page document
has two pages the last one is entirely blank?

If i have a four page Word document each with the numbers 1, 2, 3 and 4 at
the top of every page i would expect the code to produce 4 x 1 page
documents. but instead it is 3 x 2 page documents and 1 x 1 page document,
the additional pages are simply blank?

Thanks for your help so far.

Greetings from Manchester, UK.

 

[Helmut Weber]

Hi Jack,

I think, this is almost impossible to control from afar,
depending on formatting and other issues, e.g on whether
paragraphs in the original document span over more than
one page and whether the new doc is created from the
same template. The way my macro works, it doesn't
take care of formatting.

But if the behaviour is constant, then you could simply delete
the last, empty page in the newly created documents. The
last page would be nothing but an empty paragraph.

You may test something like this, before saving:

With Newdoc.Paragraphs.Last
If .Range = Chr(13) Then
.Range.Delete
End If
End With

You may even test whether Newdoc contains text at all,
except for the one empty paragraph, which is always there.

 

[Jack]

Helmut,

Thanks again for this. The original document is a form made up of two tables
and i am losing all table formatting which is a real problem. I have noticed
however that at the end of every form is the text "END OF FORM". Is it
possible to adapt the code to look for this text and then save the page as a
new page without losing all of my formatting?

 

[Helmut Weber]

Hi Jack,

one way to preserve formatting is copying and pasting.
However, for keeping formatting applied e.g. by using
a paragraph template you would have to include the
paragraph mark in the selection. Difficult, not to say
impossible, if the paragraph spans over more then one page.

A method, to look for "END OF FORM" & paragraph mark, would be:

Sub Dunno12()

Dim l As Long ' just a counter
Dim lPgs As Long ' number of pages
Dim Newdoc As Document
Dim OldDoc As Document
Set OldDoc = ActiveDocument
Selection.ExtendMode = False
ResetSearch
lPgs = OldDoc.BuiltInDocumentProperties(wdPropertyPages)
For l = 1 To lPgs
OldDoc.Activate
Selection.ExtendMode = False
Selection.GoTo what:=wdGoToPage, _
which:=wdGoToAbsolute, _
Count:=l
Selection.ExtendMode = True
With Selection.Find
.Text = "END OF FORM^p" ' Paragraph mark
.MatchCase = True
If .Execute Then
Selection.Copy
Set Newdoc = Documents.Add(Visible:=True)
Selection.Paste
Newdoc.Paragraphs.Last.Range.Delete
Newdoc.SaveAs "c:\000\fish-" & Format(l, "000") & ".doc"
Newdoc.Close
End If
End With
Next
Set Newdoc = Nothing
ResetSearch
End Sub

Public Sub ResetSearch()
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
End Sub

HTH

 

[Jack]

Helmut thank you ever so much. This worked brilliantly for me once i had
tweaked it a little. Without you i would not have known where to start.