Sub SaveToPDF()
Dim StrPath As String, StrName As String, Result
With ActiveDocument
  On Error GoTo Errhandler
  StrPath = GetFolder & "\"
  StrName = Split(.Name, ".")(0)
  While Dir(StrPath & StrName & ".pdf") <> ""
    Result = InputBox("WARNING - A file already exists with the name:" & vbCr & _
      Split(.Name, ".")(0) & vbCr & _
      "You may edit the filename or continue without editing." _
      & vbCr & vbTab & vbTab & vbTab & "Proceed?", "File Exists", StrName)
    If Result = vbCancel Then Exit Sub
    If StrName = Result Then GoTo Overwrite
    StrName = Result
  Wend
Overwrite:
  .ExportAsFixedFormat OutputFileName:=StrPath & StrName & ".pdf", _
  ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
  OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
  Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
  CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
  BitmapMissingFonts:=True, UseISO19005_1:=False
End With
Errhandler:
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

Sub ExportPagesToPDF()
Dim StrPath As String, StrName As String, Rng As Range
StrPath = GetFolder & "\"
With ActiveDocument
  Set Rng = .Range(0, 0)
  With .Range
    With .Characters.Last
      While .Previous Like "[" & Chr(9) & "-" & Chr(14) & Chr(32) & Chr(160) & "]"
        .Previous.Text = vbNullString
      Wend
    End With
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = Chr(12)
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute
    End With
    Do While .Find.Found
      Rng.End = .End
      StrName = Split(Split(Rng.Text, vbCr)(0), " ")(0)
      With Rng.Characters
        Call SavePDF(ActiveDocument, StrPath, StrName, .First.Information(wdActiveEndPageNumber), .Last.Information(wdActiveEndPageNumber))
      End With
      Rng.Collapse wdCollapseEnd
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  Rng.End = .Range.End
  StrName = Split(Split(Rng.Text, vbCr)(0), " ")(0)
  With Rng.Characters
    Call SavePDF(ActiveDocument, StrPath, StrName, .First.Information(wdActiveEndPageNumber), .Last.Information(wdActiveEndPageNumber))
  End With
End With
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
 
Sub SavePDF(Doc As Document, StrPath As String, StrName As String, StartPage As Long, EndPage As Long)
Dim Result As String
On Error GoTo Errhandler
While Dir(StrPath & StrName) <> ""
  Result = InputBox("WARNING - A file already exists with the name:" & vbCr & _
    StrName & vbCr & _
    "You may edit the filename or continue without editing." _
    & vbCr & vbTab & vbTab & vbTab & "Proceed?", "File Exists", StrName)
  If Result = "" Then Exit Sub
  If StrName = Result Then GoTo Overwrite
  StrName = Result
Wend
Overwrite:
Doc.ExportAsFixedFormat OutputFileName:=StrPath & StrName, UseISO19005_1:=False, _
  ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
  OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportFromTo, _
  From:=StartPage, To:=EndPage, Item:=wdExportDocumentContent, _
  IncludeDocProps:=True, CreateBookmarks:=wdExportCreateNoBookmarks, _
  KeepIRM:=True, DocStructureTags:=True, BitmapMissingFonts:=True
  Exit Sub
Errhandler:
  MsgBox "Error processing: " & StrName, vbExclamation
End Sub