Microsoft Office Forums - View Single Post - Split Merged Output to Separate Documents

gmayor · 01-03-2022, 04:55 AM

You have not changed the issue that is causing the error i.e.

Code:

StrTxt = ActiveDocument.Path & "" & StrTxt

If the document has been saved, the activedocument path would be e.g. "C:\Path".
If you add strTxt to this, the resulting path is "C:\pathstrTxt", whereas it should be "C:\path\strTxt"

Code:

StrTxt = ActiveDocument.Path & "\" & StrTxt

Ensure the document is saved before running the macro.

Code:

Sub SplitMergedDocument()
' Sourced from: https://www.msofficeforums.com/mail-...ps-tricks.html
    Application.ScreenUpdating = False
    Dim i As Long, j As Long, k As Long, StrTxt As String
    Dim Rng As Range, Doc As Document, HdFt As HeaderFooter
    Const StrNoChr As String = """*./\:?|"
    j = InputBox("How many Section breaks are there per record?", "Split By Sections", 1)
    With ActiveDocument
        .Save
        If .path = "" Then
            MsgBox "Save the document!", vbCritical
            Exit Sub
        End If
        ' Process each Section
        For i = 1 To .Sections.Count - 1 Step j
            With .Sections(i)
                '*****
                ' Get the 1st paragraph's text
                StrTxt = Split(.Range.Paragraphs(1).Range.Text, vbCr)(0)
                For k = 1 To Len(StrNoChr)
                    StrTxt = Replace(StrTxt, Mid(StrNoChr, k, 1), "_")
                Next
                ' Construct the destination file path & name
                StrTxt = ActiveDocument.path & "\" & StrTxt
                '*****
                ' Get the whole Section
                Set Rng = .Range
                With Rng
                    If j > 1 Then .MoveEnd wdSection, j - 1
                    'Contract the range to exclude the Section break
                    .MoveEnd wdCharacter, -1
                    ' Copy the range
                    .Copy
                End With
            End With
            ' Create the output document
            Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName, Visible:=False)
            With Doc
                ' Paste contents into the output document, preserving the formatting
                .Range.PasteAndFormat (wdFormatOriginalFormatting)
                ' Delete trailing paragraph breaks & page breaks at the end
                While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
                    .Characters.Last.Previous = vbNullString
                Wend
                ' Replicate the headers & footers
                For Each HdFt In Rng.Sections(j).Headers
                    .Sections(j).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
                Next
                For Each HdFt In Rng.Sections(j).Footers
                    .Sections(j).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
                Next
                ' Save & close the output document
                '.SaveAs FileName:=StrTxt & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
                ' and/or:
                .SaveAs FileName:=StrTxt & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
                .Close SaveChanges:=False
            End With
        Next
    End With
    Set Rng = Nothing: Set Doc = Nothing
    Application.ScreenUpdating = True
End Sub