Word 2013 - Split large (50pg+) Document into multiple documents and name each file according to delimiter

I have been trying this for days but have had no luck.

Basically I have large documents I generate, usually 50 or more pages, and on each page the user's name is surround by a delimiter I would like to use. The delimeter I want to use is /(name here)/.

The idea would be that it would split the document into multiple documents based on the name found inside the delimiter.

Here is a code I have tried but have had no success with.
Sub RenameMacro()

Dim strFilename As String

'------------------------------------------------Searches for text based on delimiter (\) and attempts to store variable-----------------
With Selection.Find
    Do While .Execute(FindText:="\\*\\", MatchWildcards:=True, Forward:=True, Wrap:=wdFindStop) = True
        With Selection
            strFilename = Replace(Selection.Text, "\", "")
            'Set Target = Documents.Add
            'Target.Range.FormattedText = Source.Bookmarks("\page").Range.FormattedText
            'Target.SaveAs2 strFilename & ".docx"
            'Target.Close
            '.Collapse wdCollapseEnd
        End With
        Loop
        End With
'------------------------------------------------Searches for text based on delimiter (\) and attempts to store variable-----------------

'------------------------------------------------Searches for text based on delimiter (\) and removes delimiter-----------------
With Selection.Find
    .Forward = True
    .Wrap = wdFindStop
    .Text = "\\"
    .Execute
    .Replacement.ClearFormatting
    .Replacement.Text = ""
    .Execute Replace:=wdReplaceAll, Forward:=True, _
        Wrap:=wdFindContinue
End With
'------------------------------------------------Searches for text based on delimiter (\) and removes delimiter-----------------


'------------------------------------------------Supposed to scour the document and generate each document after each new page based on delimiter variable strFilename---------
' Based on a Macro created 16-08-98 by Doug Robbins
 ' to save each letter created by a
 ' mailmerge as a separate file.
 'Dim Mask As String
 Dim Letters As Long
 Dim Counter As Long
 Dim DocName As String
 Dim oDoc As Document
 Dim oNewDoc As Document
 Set oDoc = ActiveDocument
 oDoc.Save
 Selection.EndKey Unit:=wdStory
 Letters = Selection.Information(wdActiveEndSectionNumber)
 'Mask = "ddMMyy"
 Selection.HomeKey Unit:=wdStory
 Counter = 1
 While Counter < Letters
 DocName = "C:\HotDocs\" & strFilename & "_test.doc"
 'DocName = "C:\HotDocs\" & (strFilename) & "_test.docx"
 'DocName = "C:\HotDocs\" & Format(Date, Mask) _
 '& " " & LTrim$(Str$(Counter)) & "_test.doc"
 oDoc.Sections.First.Range.Cut
 Set oNewDoc = Documents.Add
 'Documents are based on the Normal template
 'To use an alternative template follow the link.
 With Selection
 .Paste
 .EndKey Unit:=wdStory
 .MoveLeft Unit:=wdCharacter, Count:=1
 .Delete Unit:=wdCharacter, Count:=1
 End With
 oNewDoc.SaveAs FileName:=DocName, _
 FileFormat:=wdFormatDocument, _
 AddToRecentFiles:=False
 ActiveWindow.Close
 Counter = Counter + 1
 Wend
 oDoc.Close wdDoNotSaveChanges
'------------------------------------------------Supposed to scour the document and generate each document after each new page based on delimiter variable strFilename---------
        
End Sub

Open in new window

Any help would be greatly appreciated.
ShaneDevAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

aikimarkCommented:
Please post a representative sample document.
GrahamSkanRetiredCommented:
Try it like this:
Sub ChopDoc()
    Dim rng As Range
    Dim rngEnd As Long
    Dim rngStart As Long
    Dim rngNewDoc As Range
    Dim docBig As Document
    Dim docNew As Document
    Dim strName As String
    
    Set docBig = ActiveDocument
    Set rng = docBig.Range
    Set rngNewDoc = docBig.Range
    
    With rng.Find
        .Text = "\\*\\"
        .MatchWildcards = True
        If .Execute Then
            rngNewDoc.Start = rng.Start
            rngStart = rng.End
            strName = Replace(rng.Text, "\", "")
        Else
            MsgBox "No user names found"
            End
        End If
    End With
    
    Do
        Set rng = docBig.Range
        rng.Start = rngStart
        With rng.Find
            .Text = "\\*\\"
            .MatchWildcards = True
            If .Execute Then
                rngNewDoc.End = rng.Start
            Else
                rngNewDoc.End = ActiveDocument.Range.End
            End If
            rngStart = rng.End
            rngNewDoc.Copy
            rngNewDoc.Start = rng.Start
            
            Set docNew = Documents.Add
            docNew.Range.Paste
            docNew.SaveAs docBig.Path & "\" & strName
            docNew.Close wdDoNotSaveChanges
            strName = Replace(rng.Text, "\", "")
            If Not .Found Then
                Exit Do
            End If
       End With
    Loop
End Sub

Open in new window

ShaneDevAuthor Commented:
I have attached the document I am trying to use the macro on.

GrahamSkan,

I tried the macro but it keeps failing where I have been failing. The first page's delimiter isn't realized and it only works if you have the second or third page with a delimiter but it only creates the last page file.
C--HotDocs-Test1.docx
GrahamSkanRetiredCommented:
Your first delimiter pair contains a Mergefield rather than ordinary text, so the Find skips it and returns the text between  the second delimiter and the first delimiter of the second pair.
It would be better to run the merge to a document and to work on that. However, I have added some code that converts all the fields to text. It works on the sample.
Sub ChopDoc()
    Dim rng As Range
    Dim rngEnd As Long
    Dim rngStart As Long
    Dim rngNewDoc As Range
    Dim docBig As Document
    Dim docNew As Document
    Dim strName As String
    
    Set docBig = ActiveDocument
    Set rng = docBig.Range
    Set rngNewDoc = docBig.Range
    With docBig.Fields
        .Unlink
    End With
    With rng.Find
        .Text = "\\*\\"
        .MatchWildcards = True
        If .Execute Then
            rngNewDoc.Start = rng.Start
            rngStart = rng.End
            strName = Replace(rng.Text, "\", "")
        Else
            MsgBox "No user names found"
            End
        End If
    End With
    
    Do
        Set rng = docBig.Range
        rng.Start = rngStart
        With rng.Find
            .Text = "\\*\\"
            .MatchWildcards = True
            If .Execute Then
                rngNewDoc.End = rng.Start
            Else
                rngNewDoc.End = ActiveDocument.Range.End
            End If
            rngStart = rng.End
            rngNewDoc.Copy
            rngNewDoc.Start = rng.Start
            
            Set docNew = Documents.Add
            docNew.Range.Paste
            docNew.SaveAs docBig.Path & "\" & strName & ".docx", wdFormatXMLDocument
            docNew.Close wdDoNotSaveChanges
            strName = Replace(rng.Text, "\", "")
            If Not .Found Then
                Exit Do
            End If
       End With
    Loop
End Sub 

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Word

From novice to tech pro — start learning today.