Split Word 2010 Document

[Jezza]

It is a long time since I have touched on Word VBA and it seems to have moved faster than me

I have a code generated RTF file that has been generated a large mail merged file, my user wants some code that will split the document and save it as separate documents. This is a not a page by page break but where a manual page break is, which marks the end and beginning of each individual letter.

I have found this code on the interweb thingy which unfortunately splits it on each page:

Code: Select all

Sub splitter()

Dim Counter As Long, Source As Document, Target As Document
Set Source = ActiveDocument
Selection.HomeKey Unit:=wdStory
Pages = Source.BuiltInDocumentProperties(wdPropertyPages)
Counter = 0
While Counter < Pages
    Counter = Counter + 1
    DocName = "Page" & Format(Counter)
    Source.Select
    Source.Bookmarks("\Page").Range.Cut
    Set Target = Documents.Add
    Target.Range.Paste
    Target.SaveAs FileName:=DocName
    Target.Close
Wend
End Sub

What do I need to do to get it to break at each manual page break and save the entire selection

[HansV]

Try this - it may need a bit of tweaking.

Code: Select all

Sub Splitter2()
    Dim p1 As Long
    Dim p2 As Long
    Dim doc As Document
    Dim n As Long
    Application.ScreenUpdating = False
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Text = "^m"
        Do While .Execute
            n = n + 1
            p2 = Selection.Start
            ActiveDocument.Range(p1, p2).Copy
            Set doc = Documents.Add
            Selection.Paste
            ' Modify name as needed; you can add a path
            doc.SaveAs "Doc" & n & ".docx", wdFormatXMLDocument
            doc.Close
            p1 = p2 + 1
        Loop
    End With
    ' Rest of document
    n = n + 1
    p2 = ActiveDocument.Content.End
    ActiveDocument.Range(p1, p2).Copy
    Set doc = Documents.Add
    Selection.Paste
    ' Modify name as needed; you can add a path
    doc.SaveAs "Doc" & n & ".docx", wdFormatXMLDocument
    doc.Close
    Application.ScreenUpdating = True
End Sub

[Jezza]

Thanks Hans,

However it appears these letters have the name and address of the recipient in a table at the top of each one and when this code is run the formatting goes awry. Is this because the table has a hidden page break?

[HansV]

That's impossible to tell without seeing a sample document, sorry.

[Jezza]

Hopefully this will assist

[HansV]

Thanks! Try this version, hopefully it preserves the formatting better.

Code: Select all

Sub Splitter2()
    Dim p1 As Long
    Dim p2 As Long
    Dim doc As Document
    Dim n As Long
    Application.ScreenUpdating = False
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Text = "^m"
        Do While .Execute
            n = n + 1
            p2 = Selection.Start
            ActiveDocument.Range(p1, p2).Copy
            Set doc = Documents.Add
            Selection.Paste
            ' Modify name as needed; you can add a path
            doc.SaveAs "Doc" & n & ".docx", wdFormatXMLDocument, , , False
            doc.Close
            p1 = p2 + 1
        Loop
    End With
    ' Rest of document
    n = n + 1
    p2 = ActiveDocument.Content.End
    ActiveDocument.Range(p1, p2).Copy
    Set doc = Documents.Add
    Selection.PasteAndFormat wdFormatOriginalFormatting
    ' Modify name as needed; you can add a path
    doc.SaveAs "Doc" & n & ".docx", wdFormatXMLDocument
    doc.Close
    Application.ScreenUpdating = True
End Sub

[Jezza]

Perfect, thank you