asked on

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.

aikimark

Please post a representative sample document.

GrahamSkan

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

ShaneDev

ASKER

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

ASKER CERTIFIED SOLUTION

GrahamSkan

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial