Option Explicit
Sub SaveAsSeparatePDFs()
'---------------------------------------------------------------------------------------------------
'---Script: SaveAsSeparatePDFs----------------------------------------------------------------------
'---Description: This subroutine saves MS Word document pages as separate PDFs with file names------
'----------------formatted like Page_x.pdf.---------------------------------------------------------
'---------------------------------------------------------------------------------------------------
 
Dim strDirectory As String, strTemp As String
Dim ipgStart As Integer, ipgEnd As Integer
Dim iPDFnum As Integer, i As Integer
Dim vMsg As Variant, bError As Boolean
 
1:
strDirectory = InputBox("Directory to save individual PDFs? " & _
vbNewLine & "(ex: C:\Users\Public)")
If strDirectory = "" Then Exit Sub
If Dir(strDirectory, vbDirectory) = "" Then
  vMsg = MsgBox("Please enter a valid directory.", vbOKCancel, "Invalid Directory")
  If vMsg = 1 Then
    GoTo 1
  Else
    Exit Sub
  End If
End If
2:
strTemp = InputBox("Begin saving PDFs starting with page __? " & _
  vbNewLine & "(ex: 32)")
bError = bErrorF(strTemp)
If bError = True Then GoTo 2
ipgStart = CInt(strTemp)
3:
strTemp = InputBox("Save PDFs until page __?" & vbNewLine & "(ex: 37)")
bError = bErrorF(strTemp)
If bError = True Then GoTo 3
ipgEnd = CInt(strTemp)
 
iPDFnum = ipgStart
On Error GoTo 4:
For i = ipgStart To ipgEnd
  ActiveDocument.ExportAsFixedFormat OutputFileName:= _
    strDirectory & "\Page_" & iPDFnum & ".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
    iPDFnum = iPDFnum + 1
Next i
End
4:
vMsg = MsgBox("Unknown error encountered while creating PDFs." & vbNewLine & vbNewLine & _
  "Aborting", vbCritical, "Error Encountered")
End Sub

Private Function bErrorF(strTemp As String) As Boolean
Dim i As Integer, vMsg As Variant
bErrorF = False
If strTemp = "" Then
  End
ElseIf IsNumeric(strTemp) = True Then
  i = CInt(strTemp)
  If i > ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) Or i <= 0 Then
    Call msgS(bErrorF)
  End If
Else
  Call msgS(bErrorF)
End If
End Function

Private Sub msgS(bMsg As Boolean)
Dim vMsg As Variant
vMsg = MsgBox("Please enter a valid integer." & vbNewLine & vbNewLine & _
  "Integer must be > 0 and < total pages in the document (" & _
  ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) & ")", vbOKCancel, "Invalid Integer")
If vMsg = 1 Then
  bMsg = True
Else
  End
End If
End Sub