split_docx

Sub testFileSplit()
    Call SplitNotes("///", "C:\Users\myPath\temp_DEL_008_000.docx")
End Sub
Sub SplitNotes(strDelim As String, strFilename As String)
    Dim docNew As Document
    Dim i As Long
    Dim colNotes As Collection
    Dim temp As Range

    'get the collection of ranges
    Set colNotes = fGetCollectionOfRanges(ActiveDocument, strDelim)

    'see if the user wants to proceed
    If MsgBox("This will split the document into " & _
    colNotes.Count & _
    " sections. Do you wish to proceed?", vbYesNo) = vbNo Then
        Exit Sub
    End If

     'go through the collection of ranges
    For i = 1 To colNotes.Count
         'create a new document
        Set docNew = Documents.Add

        'copy our range
        colNotes(i).Copy
         'paste it in
        docNew.Content.Paste
         'save it
        docNew.SaveAs fileName:=ThisDocument.path & "\" & strFilename & Format(i, "000"), FileFormat:=wdFormatDocument

        docNew.Close
    Next
End Sub
Function fGetCollectionOfRanges(oDoc As Document, strDelim As String) As Collection
    Dim colReturn As Collection
    Dim rngSearch As Range
    Dim rngFound As Range

     'initialize a new collection
    Set colReturn = New Collection
     'initialize our starting ranges
    Set rngSearch = oDoc.Content
    Set rngFound = rngSearch.Duplicate

     'start our loop
    Do
         'search through
        With rngSearch.Find
            .Text = strDelim
            .Execute
             'if we found it... prepare to add to our collection
            If .Found Then
                 'redefine our rngfound
                rngFound.End = rngSearch.Start
                 'add it to our collection
                colReturn.Add rngFound.Duplicate
                 'reset our search and found for the next
                rngSearch.Collapse wdCollapseEnd
                rngFound.Start = rngSearch.Start
                rngSearch.End = oDoc.Content.End
            Else
                 'if we didn't find, exit our loop
                Exit Do
            End If
        End With
         'shouldn't ever hit this... unless the delimter passed in is a VBCR
    Loop Until rngSearch.Start >= ActiveDocument.Content.End

     'and return our collection
    Set fGetCollectionOfRanges = colReturn
End Function