Solved: Macro to cut one Word doc into many small ones

[moyom nagy]

Hi everyone. I was wondering if someone might be able to help me code a macro to do the following.

Let?s say I have a Word document, called ?My notes?, which is full of notes. Each individual "note" is a (potentially long) text passage which ends with a specific delimiter, for example, " /// ?

Let?s say there are 30 notes in the My notes.doc. I need a macro which will copy each note into its own new doc, and give the new doc a name (eg. ?My notes snipped 0001.doc?, ?My notes snipped 0002.doc? etc.) save it, and close it. So after running the macro, there should be 31 docs: the original "My notes.doc" as well as "My notes snipped 0001.doc" through "My notes snipped 0030.doc".

Ideally there should be no limit to how many notes are in My notes.doc, although if limitlessness makes this harder to code, 2,000 should be plenty.

Also ideally, I should be able to easily change
n what I want the delimiter to be, and
n the non-unique part of the cut-up file name (in the example above, change from ?My notes snipped 0001.doc? to ?Cool stuff 0001.doc?).


I?d be grateful for any help.

[lucas]

This code uses Heading1 style at the beginning of the snips to separate the docs. Filename is also configurable in the code.
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

[moyom nagy]

Lucas,

Thanks very much. Though can I ask -- how would the code look if a simple text delimiter, say, "///" were used instead of heading style 1?

I ask because I want to chop up a lot of existing text which either uses that delimiter, or has some other text delimiter which via search & replace I can easily turn into the "///" delimiter. I must confess I'm not a Word power user, and don't really even now what a heading style is...:dunno

[lucas]

This seems to work but you need to use find and replace to pick a different delimiter before you start as it really doesn't like / as a filename...so try 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.Text = "/" 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 & "\" & "My Filename" & (x) & ".doc"
ActiveDocument.Close
Next x
End Sub

[Norie]

Not done much Word VBA recently, but I'm bored and came up with this.


Sub SplitNotes(delim As String, strFilename As String)
Dim doc As Document
Dim arrNotes
Dim I As Long
Dim X As Long

arrNotes = Split(ActiveDocument.Range, delim)

For I = LBound(arrNotes) To UBound(arrNotes)
If Trim(arrNotes(I)) <> "" Then
X = X + 1
Set doc = Documents.Add
doc.Range = arrNotes(I)
doc.SaveAs ThisDocument.Path & "\" & strFilename & Format(X, "000")
doc.Close True
End If
Next I

End Sub

Sub test()
SplitNotes "///", "Notes "
End Sub

[lucas]

that works nicely Norie....

[moyom nagy]

Maybe I'm doing something wrong.

I put your code into standard VBA module. Since it doesn't like "/" I'm using another delimiter: "ENDSHERE".

In the doc I'm running the code in (see attached), each passage which is to be copied into its own unique doc ends with the text "ENDSHERE".


So I've changed your code so that it now looks like 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.Text = "ENDSHERE" 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 & "/" & "My Filename" & (x) & ".doc"
ActiveDocument.Close
Next x
End Sub


When I run the macro, it seems to just scroll through the doc, without finding, selecting, copying, creating a new document etc.


What have I done wrong?

[lucas]

You should try Nories code. It gives you complete control over the delimiter and the filename. I added an extra delimiter to the very top of your page to get it started correctly. Change delimiter and filename in the sub Test

[Norie]

Steve

Thank you very much.:)

But it isn't perfect, it always seems to create an extra, seemingly blank workbook, er I mean document.

I think, but I'm not sure, that it's due to Chr(13).

[moyom nagy]

Norie, that works brilliantly. Thanks a lot. And thank you Lucas as well.:cloud9:

[lucas]

hmm....lets look it over and see if we can figure it out Norie. When we get it done would you contribute it to the kb?

[lucas]

Hi moyom nagy,
Your welcome but Norie gets the credit here.....glad you got a working solution. Be sure to mark your thread solved using the thread tools at the top of the page if your happy with it. You can always post followup questions here later if need be.

[lucas]

Hey Norie, it doesn't seem to add the empty doc if the delimiter is at the top of each section.......moyom nagy's example ends with a delimiter. Could that be causing the problem.

Attached example for evaluation..