Split a Document

[Saad]

Hi

I am not sure if this question was asked before, tried searching the forum
but couldn’t find a relative topic.

Basically I have a huge document consisting of abstracts for a conference. I
have been asked to make individual file of each abstract, which means to copy
paste each abstract from the main document into a new document. I was hoping
that I can do it using VBA and avoid the manual work. Now the real issue is
there is no text to identify start of an abstract, only way is to identify it
is by its title which is Bold Times New Roman 12.

The algorithm I am thinking of is to parse this document and look for the
title, which will be basically to look for a line which is Bold Times New
Roman 12 and then keep selecting the text till I find title of the next
abstract means another line with Bold Times New Roman 12, open a new document
and paste the selection into the new doc and move on to the next abstract.

Or I can make a document like a TOC which lists all the abstract titles and
from this document read two adjacent titles, select all the text in between
those two lines from my main document and paste into a new document and move
on to the next title.

Or maybe the third way is to manually put tags at the start and end of an
abstract and use those tags to select text in between and create new
documents?

So which method you guys think will be easier to implement and ofcourse some
sample code will help, since this is the first time I am using VBA? Thanks
for the help

 

[Graham Mayor]

Provided there are no section breaks in the document, the following will
split the document at each Times New Roman Bold 12 title into separate files
named according to that title with the addition of a number into a folder
d:\My Documents\Test\Merge. Change that folder path where indicated to some
suitable location on your hard drive. May I suggest that you work with a
COPY of the document!!! http://www.gmayor.com/installing_macro.htm

Sub SplitAtFont()
Dim mask As String
Letters = Selection.Information(wdActiveEndSectionNumber)
With Selection
.HomeKey Unit:=wdStory
.MoveDown Unit:=wdLine
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Font.name = "Times New Roman"
.Font.Size = "12"
.Font.Bold = True
.Wrap = wdFindStop
Do While .Execute
With Selection
.HomeKey Unit:=wdLine
.InsertBreak Type:=wdSectionBreakContinuous
.MoveDown Unit:=wdLine
End With
Loop
End With
.EndKey Unit:=wdStory
.InsertBreak Type:=wdSectionBreakContinuous
End With
Letters = Selection.Information(wdActiveEndSectionNumber)
Selection.HomeKey Unit:=wdStory
Counter = 1
While Counter < Letters
Application.ScreenUpdating = False
With Selection
.HomeKey Unit:=wdStory
.EndKey Unit:=wdLine, Extend:=wdExtend
.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
End With
sName = Selection
'***********************************
docName = "D:\My Documents\Test\Merge\" & sName & Counter & ".doc"
'***********************************
ActiveDocument.Sections.First.Range.Cut
Documents.Add
With Selection
.Paste
.HomeKey Unit:=wdStory
.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
.Delete
End With
ActiveDocument.SaveAs FileName:=docName, _
FileFormat:=wdFormatDocument
ActiveWindow.Close
Counter = Counter + 1
Application.ScreenUpdating = True
Wend
End Sub


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

 

[Saad]

Hey thanks I havn't checked this code yet but will do in morning, and yea
document has sections but I can either first split it on basis of sections
using foreach or I can do it manually theer arnt many sections

thanks again

 

[Saad]

Hello Graham , I am afraid there is something slightly wrong with my file or
code because the code gets stuck in an infinite loop. Plus I am not able to
understand the code otherwise would have had solved the problem, is there any
reference or starting tutorial on VBA and Word Objects?

Thanks

 

[Graham Mayor]

Probably a bit of both

I have tidied the code up and annotated it. See if that helps. It would help
to replace any section breaks with a paragraph break first. ie replace ^b
with ^p as section breaks will confuse the second part of the macro.

Sub SplitAtFont()
Dim Letters As Integer
Dim Counter As Long
Dim sName As String
Dim docName As String

Application.ScreenUpdating = False
With Selection
.HomeKey Unit:=wdStory 'move to the start of the document
.MoveDown Unit:=wdLine 'move down one line
With .Find 'locate Times New Roman 12 point Bold
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Font.name = "Times New Roman"
.Font.Size = "12"
.Font.Bold = True
.Wrap = wdFindStop
Do While .Execute ' and when found
With Selection
.HomeKey Unit:=wdLine 'move to the start of the line
'and insert a section break
.InsertBreak Type:=wdSectionBreakContinuous
.MoveDown Unit:=wdLine 'move down one line
End With
Loop ' then find the next TNR 12 pont Bold
End With
.EndKey Unit:=wdStory ' go to the end of the document
' and add a section break
.InsertBreak Type:=wdSectionBreakContinuous
End With
'define what Letters is
Letters = Selection.Information(wdActiveEndSectionNumber)
'go to the top of tyeh document
Selection.HomeKey Unit:=wdStory
Counter = 1 'set a counter
While Counter < Letters 'set the limits of the counter
Application.ScreenUpdating = False
With Selection 'grab some of the first line as a filename
.HomeKey Unit:=wdStory
.EndKey Unit:=wdLine, Extend:=wdExtend
.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
End With
sName = Selection 'and apply it to a variable
'***********************************
'Format the name for the split document
docName = "D:\My Documents\Test\Merge\" & sName & Counter & ".doc"
'***********************************
'Cut the first section to the clipboard
ActiveDocument.Sections.First.Range.Cut
Documents.Add 'open a new document
Selection.Paste ' and paste the clipboard content
'Save the document with the chosen filename
ActiveDocument.SaveAs FileName:=docName, _
FileFormat:=wdFormatDocument
ActiveWindow.Close 'and close it
Counter = Counter + 1 'increment the counter
'Then go round again
Wend
Application.ScreenUpdating = True
End Sub


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>