Extract Acrobat PDF pages based on page number ranges into one PDF

[brawnystaff]

I have Excel and Acrobat Pro on my computer. I am using the code below to extract page ranges from a PDF and save each page range to a separate file (Column A would have file name, B would be the Start page, C would be the end page). I am trying to modify the macro that that instead of saving each PDF range to a separate file, it saves it to just one file. Any ideas on how to do this? Thanks

Option Explicit

Sub ExtractPDFPages()
'Extract various pages from PDF
'3 Column Spreadsheet: Column A - Name, Column B - Start page, Column C - End page
Dim strSourceFullPath As String, strDestinationFullPath As String
Dim iStartPage As Long, iNumPages As Long
Dim PDDocSource As Object, PDDocTarget As Object
Dim Cell As Range, Rng As Range
Application.ScreenUpdating = False
    Set PDDocSource = CreateObject("AcroExch.PDDoc")
    Set PDDocTarget = CreateObject("AcroExch.PDDoc")
    Set Rng = Selection
   
    strSourceFullPath = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf")
       
    For Each Cell In Rng
    strDestinationFullPath = StripFilename(strSourceFullPath) & Cell & ".pdf"
   
    ' Create a new PDDoc
    If PDDocTarget.Create <> True Then
        MsgBox "Unable to create a new PDF"
        Exit Sub
    End If
  
    ' Open the PDF source file (the file we are going to take pages from)
    If PDDocSource.Open(strSourceFullPath) <> True Then
        MsgBox "Unable to open the source PDF"
        Exit Sub
    End If
  
    ' Set the page range you wish to extract
    ' Don't forget that this is zero based
    iStartPage = (Cell.Offset(0, 1) - 1)
  
    ' Set the number of pages you wish to extract
    iNumPages = (Cell.Offset(0, 2) - iStartPage)
       
     
      ' Insert the pages from the source PDF file to the target PDF
    If PDDocTarget.InsertPages(-1, PDDocSource, iStartPage, iNumPages, False) <> True Then
        MsgBox "Unable to insert the source pages"
        Exit Sub
    End If
  
    ' Save the new file
    If PDDocTarget.Save(&H1, strDestinationFullPath) <> True Then
        MsgBox "Unable to save the pdf"
        Exit Sub
    End If
  
    'Close the PDF files
    PDDocSource.Close
    PDDocTarget.Close
   
    Next Cell
  
    ' Clean up
    Set PDDocSource = Nothing
    Set PDDocTarget = Nothing
    Application.ScreenUpdating = True
   MsgBox "Complete"
End Sub
Function StripFilename(sPathFile As String) As String
'given a full path and file, strip the filename off the end and return the path
Dim filesystem As Object

Set filesystem = CreateObject("Scripting.FilesystemObject")

StripFilename = filesystem.GetParentFolderName(sPathFile) & "\"

Exit Function

End Function