Save Word doc as separate PDFs with specific name

[miketa]

Dear all,

I'm trying to get a macro to have a Word doc (containing multiple pages) split for each page according to specific criteria and each of the created pages saved as a PDF.

So far, I've managed to find below macro, which solves my issue, except of the fact that the PDF files are being saved as Page 1, Page 2, etc.

Sub SaveAsSeparatePDFs()
    Dim I As Long
    Dim xDlg As FileDialog
    Dim xFolder As Variant
    Dim xStart, xEnd As Integer
    On Error GoTo lbl
    Set xDlg = Application.FileDialog(msoFileDialogFolderPicker)
    If xDlg.Show <> -1 Then Exit Sub
    xFolder = xDlg.SelectedItems(1)
    xStart = CInt(InputBox("Start Page", "Page range"))
    xEnd = CInt(InputBox("End Page:", "Page range"))
    If xStart <= xEnd Then
        For I = xStart To xEnd
            ActiveDocument.ExportAsFixedFormat OutputFileName:= _
                xFolder & "\Page_" & I & ".pdf", ExportFormat:=wdExportFormatPDF, _
                OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
                wdExportFromTo, From:=I, To:=I, Item:=wdExportDocumentContent, _
                IncludeDocProps:=False, KeepIRM:=False, CreateBookmarks:= _
                wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
                BitmapMissingFonts:=False, UseISO19005_1:=False
        Next
    End If
    Exit Sub
lbl:
    MsgBox "Enter right page number", vbInformation, "Page range"
End Sub

I'd like to have a specific value used as the name of the PDF doc, which appears on every page in the 3rd line, 39 characters from the left.

In addition, is there a possibility to define a folder in the macro where the PDF's can be saved by default?

Thanks a lot for your help!
Mirza

[gmayor]

This is not as straightforward as you might imagine. There are no 'pages' in a Word document. The displayed pages are the result of text flow between the current margins and as that flow is somewhat volatile, a location described as a name starting 39 characters from the left in the third 'line' has the additional complication of determining where the name ends. Similarly there are no lines in a document for the same reason. Do you mean the displayed line or the third paragraph?
The folder is much simpler to define. Instead of selecting xFolder assign a fixed path to xFolder

Const xFolder as String = "C:\Path"

If this document is the result of a mail merge then see https://www.gmayor.com/MergeAndSplit.htm.

[miketa]

Hi Graham,

thank you for your feedback.

1. I've replaced xFolder by your suggestion and I get an error message "Syntax error", can you pls let me know what I might be doing wrong?

2. To explain the topic with the pages/text position.. I have another macro to perform a page break before exporting as PDF:

Sub InsertBreaks()
    Dim lngCounter As Long
    Application.ScreenUpdating = False
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .Text = "SITE"
        .ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        Do While .Execute
            lngCounter = lngCounter + 1
            If lngCounter Mod 2 = 1 Then
                Selection.Collapse Direction:=wdCollapseStart
                Selection.InsertBreak Type:=wdPageBreak
                Selection.MoveRight Count:=5
            End If
        Loop
    End With
    Application.ScreenUpdating = True
End Sub

This allows me to have every page in Word in an identical order/format and there, the term/invoice number I'd like to use for the PDF name, is always in the 3rd line, 39 characters from the left. I hope this explains a little better.. I'd love to share such a Word doc to show you, but as this is quite sensitive data, I hesitate.

Last but not least, is there a possibility to combine the 2 macros into one to have first the page break performed and then saving/exporting the files?

Thank you so much
Mirza

[macropod]

Instead of splitting the documents after you've done a mailmerge, split them during the mailmerge. See Send Mailmerge Output to Individual Files in the Mailmerge Tips and Tricks page at:
https://www.msofficeforums.com/mail-...ps-tricks.html
If you're wedded to doing a post-merge split, see Split Merged Output to Separate Documents on the same page.

[miketa]

Hi Paul,

this is not related to a mailmerge, there is no linked data available. I extract the data from a system into a txt file, which I convert to Word and then would like to apply the macros as described above.

Rgds
Mirza

[gmayor]

Without access to the document it is difficult to be certain, but, as Paul and I have suggested, if this relates to a mail merge, you should split the merge on the fly.
However if it is the result of a mail merge then that merge should already be split with section breaks, which appears not to be the case, or there would be no need to insert page breaks.
I would however suggest adding those section breaks rather than page breaks and adjust your code to match. The naming is still a grey area as you haven't indicated where the name ends, but making educated guesses the following may work for you and combines the functionality of both modified macros. Test it on a copy of your document and change the path of xFolder as required.

Option Explicit

Sub SaveAsSeparatePDFs()
Const xFolder As String = "C:\Path\"
Dim i As Long
Dim sName As String
Dim oRng As Range
    On Error GoTo lbl
    InsertBreaks
    For i = 1 To ActiveDocument.Sections.Count
        Set oRng = ActiveDocument.Sections(i).Range
        oRng.Collapse 1
        oRng.Select
        Selection.MoveDown Unit:=wdLine, Count:=2
        Selection.MoveRight Unit:=wdCharacter, Count:=39
        Set oRng = Selection.Range
        oRng.MoveEndUntil Chr(32)
        sName = oRng.Text
        ActiveDocument.ExportAsFixedFormat _
                OutputFileName:=xFolder & sName & ".pdf", _
                ExportFormat:=wdExportFormatPDF, _
                OpenAfterExport:=False, _
                OptimizeFor:=wdExportOptimizeForPrint, _
                Range:=wdExportCurrentPage, From:=1, to:=1, _
                Item:=wdExportDocumentContent, _
                IncludeDocProps:=True, _
                KeepIRM:=True, _
                CreateBookmarks:=wdExportCreateNoBookmarks, _
                DocStructureTags:=True, _
                BitmapMissingFonts:=True, _
                UseISO19005_1:=True
    Next i
    Exit Sub
lbl:
    MsgBox "Enter right page number", vbInformation, "Page range"
End Sub

Private Sub InsertBreaks()
    Dim lngCounter As Long
    Application.ScreenUpdating = False
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .Text = "SITE"
        .ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        Do While .Execute
            lngCounter = lngCounter + 1
            If lngCounter Mod 2 = 0 Then
                Selection.Collapse direction:=wdCollapseStart
                Selection.InsertBreak Type:=wdSectionBreakNextPage
                Selection.MoveRight Count:=5
            End If
        Loop
    End With
    Application.ScreenUpdating = True
End Sub

[miketa]

Hi Graham,

thanks for this, but somehow it doesn't seem to work properly for me.

I'm attaching the Word doc as reference. To explain the aim of the exercise:

- each of the orders begins with "SITE ...", so the page break should be there to have this as first thing on each page
- the order # is marked in yellow and this is what I wanted to have as the PDF name when saving

Can you pls have a look and let me know what the best macro for this would be?

Thanks again for the help!
Mirza

[gmayor]

It always helps to see a sample document. The 'name ' was not marked in yellow and the order number is in the second paragraph not the third. However I have modified the code and it works with your document.

Option Explicit
'Graham Mayor - https://www.gmayor.com - Last updated - 18 Mar 2022 
Sub SaveAsSeparatePDFs()
Const xFolder As String = "C:\Path\" 'change as required
Dim i As Long
Dim sName As String
Dim oRng As Range
    On Error GoTo lbl
    InsertBreaks
    For i = 1 To ActiveDocument.Sections.Count
        Set oRng = ActiveDocument.Sections(i).Range.Paragraphs(2).Range
        oRng.MoveStart wdCharacter, 38
        oRng.Collapse 1
        oRng.MoveEndUntil Chr(32)
        sName = Trim(oRng.Text)
        oRng.Select
        ActiveDocument.ExportAsFixedFormat _
                OutputFileName:=xFolder & sName & ".pdf", _
                ExportFormat:=wdExportFormatPDF, _
                OpenAfterExport:=False, _
                OptimizeFor:=wdExportOptimizeForPrint, _
                Range:=wdExportCurrentPage, From:=1, to:=1, _
                Item:=wdExportDocumentContent, _
                IncludeDocProps:=True, _
                KeepIRM:=True, _
                CreateBookmarks:=wdExportCreateNoBookmarks, _
                DocStructureTags:=True, _
                BitmapMissingFonts:=True, _
                UseISO19005_1:=True
    Next i
    Exit Sub
lbl:
    MsgBox "Error number " & Err.Number & vbCr & Err.Description, vbCritical, "Untrapped error"
End Sub

Private Sub InsertBreaks()
Dim lngCounter As Long
Dim oRng As Range, oFound As Range
    Application.ScreenUpdating = False
    Set oRng = ActiveDocument.Range
    With oRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "SITE"
        .Forward = True
        .Wrap = wdFindStop
        Do While .Execute
            lngCounter = lngCounter + 1
            Set oFound = oRng.Paragraphs(1).Range
            oFound.Collapse 1
            If lngCounter > 1 Then
                oFound.InsertBreak Type:=wdSectionBreakNextPage
            End If
            oRng.Collapse 0
        Loop
    End With
    Application.ScreenUpdating = True
End Sub

[miketa]

It always helps to see a sample document. The 'name ' was not marked in yellow and the order number is in the second paragraph not the third. However I have modified the code and it works with your document.

Option Explicit
'Graham Mayor - https://www.gmayor.com - Last updated - 18 Mar 2022 
Sub SaveAsSeparatePDFs()
Const xFolder As String = "C:\Path\" 'change as required
Dim i As Long
Dim sName As String
Dim oRng As Range
    On Error GoTo lbl
    InsertBreaks
    For i = 1 To ActiveDocument.Sections.Count
        Set oRng = ActiveDocument.Sections(i).Range.Paragraphs(2).Range
        oRng.MoveStart wdCharacter, 38
        oRng.Collapse 1
        oRng.MoveEndUntil Chr(32)
        sName = Trim(oRng.Text)
        oRng.Select
        ActiveDocument.ExportAsFixedFormat _
                OutputFileName:=xFolder & sName & ".pdf", _
                ExportFormat:=wdExportFormatPDF, _
                OpenAfterExport:=False, _
                OptimizeFor:=wdExportOptimizeForPrint, _
                Range:=wdExportCurrentPage, From:=1, to:=1, _
                Item:=wdExportDocumentContent, _
                IncludeDocProps:=True, _
                KeepIRM:=True, _
                CreateBookmarks:=wdExportCreateNoBookmarks, _
                DocStructureTags:=True, _
                BitmapMissingFonts:=True, _
                UseISO19005_1:=True
    Next i
    Exit Sub
lbl:
    MsgBox "Error number " & Err.Number & vbCr & Err.Description, vbCritical, "Untrapped error"
End Sub

Private Sub InsertBreaks()
Dim lngCounter As Long
Dim oRng As Range, oFound As Range
    Application.ScreenUpdating = False
    Set oRng = ActiveDocument.Range
    With oRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "SITE"
        .Forward = True
        .Wrap = wdFindStop
        Do While .Execute
            lngCounter = lngCounter + 1
            Set oFound = oRng.Paragraphs(1).Range
            oFound.Collapse 1
            If lngCounter > 1 Then
                oFound.InsertBreak Type:=wdSectionBreakNextPage
            End If
            oRng.Collapse 0
        Loop
    End With
    Application.ScreenUpdating = True
End Sub

This is perfect! Thanks a lot for your precious help Graham! I owe you one :-)

BR
Mirza