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-merge/21803-mailmerge-tips-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