VBA | Save Excel Sheets as PDF and keep Excel File Name and Path

[mjb342]

Hello,

I’m trying to save specific sheets defined by the user in a Table to PDF. I want the PDF to have the same name as the excel file minus the extension. I also want it saved to the same directory as where the excel file resides. It seems to work, but if I move a copy of the file to a new location it saves the PDF in the original file location and not where a copy of the excel file was moved to.

Any help is greatly appreciated.

Public Sub CreatePDF()
Dim TOCTable1 As ListObject
Dim PDFSheets() As String
Dim c As Byte 'number of tabs to be exported
Dim FileName As String
Dim FileOnly As String
Dim filePath As String

On Error GoTo Handle:

FileOnly = ThisWorkbook.Name
filePath = ThisWorkbook.FullName
FileName = FileOnly
If InStr(FileName, ".xls") > 0 Then
FileName = Left(FileName, InStr(FileName, ".") - 1)
End If
Set TOCTable1 = Worksheets("Index").ListObjects("TOCTable1")
ReDim PDFSheets(1 To TOCTable1.DataBodyRange.Rows.Count)
'fill up the array
For c = 1 To UBound(PDFSheets)
PDFSheets(c) = TOCTable1.DataBodyRange(c, 1).Value
Next c
Worksheets(PDFSheets).Select
ActiveSheet.ExportAsFixedFormat xlTypePDF, FileName
Worksheets("Index").Select
MsgBox "PDF file was created." & vbNewLine & "File is called Provision. It is saved on the same directory as this workbook.", , "Well Done"
Exit Sub

Handle:
If Err.Number = 9 Then
MsgBox "It looks like a tab name was not spelled correctly. Please double check."
Else
MsgBox "Looks like error here. Please ensure sheets are visible..."
End If

End Sub

 

[Trebor76]

Hi mjb342,

Try this:

Option Explicit
Public Sub CreatePDF()

    Dim TOCTable1 As ListObject
    Dim PDFSheets() As String
    Dim c As Byte 'number of tabs to be exported
    Dim strFullPath As String, strFileName As String, strPath As String
    
    On Error GoTo Handle:
    
    strFullPath = ThisWorkbook.FullName
    strFileName = Left(Dir(strFullPath), InStr(Dir(strFullPath), ".") - 1)
    strPath = Replace(strFullPath, Dir(strFullPath), "")
    
    Set TOCTable1 = Worksheets("Index").ListObjects("TOCTable1")
    ReDim PDFSheets(1 To TOCTable1.DataBodyRange.Rows.Count)
    'fill up the array
    For c = 1 To UBound(PDFSheets)
        PDFSheets(c) = TOCTable1.DataBodyRange(c, 1).Value
    Next c
    Worksheets(PDFSheets).Select
    ActiveSheet.ExportAsFixedFormat xlTypePDF, strPath & strFileName
    Worksheets("Index").Select
    MsgBox "PDF file was created." & vbNewLine & "File is called Provision. It is saved on the same directory as this workbook.", , "Well Done"
    Exit Sub
    
Handle:
    If Err.Number = 9 Then
    MsgBox "It looks like a tab name was not spelled correctly. Please double check."
    Else
    MsgBox "Looks like error here. Please ensure sheets are visible..."
    End If

End Sub

Regards,

Robert

 

[John_w]

It seems to work, but if I move a copy of the file to a new location it saves the PDF in the original file location and not where a copy of the excel file was moved to.

Replace:

FileOnly = ThisWorkbook.Name
filePath = ThisWorkbook.FullName
FileName = FileOnly
If InStr(FileName, ".xls") > 0 Then
FileName = Left(FileName, InStr(FileName, ".") - 1)
End If

with:

    Filename = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, ".")) & "pdf"

 

[mjb342]

Hi mjb342,

Try this:

Option Explicit
Public Sub CreatePDF()

    Dim TOCTable1 As ListObject
    Dim PDFSheets() As String
    Dim c As Byte 'number of tabs to be exported
    Dim strFullPath As String, strFileName As String, strPath As String
   
    On Error GoTo Handle:
   
    strFullPath = ThisWorkbook.FullName
    strFileName = Left(Dir(strFullPath), InStr(Dir(strFullPath), ".") - 1)
    strPath = Replace(strFullPath, Dir(strFullPath), "")
   
    Set TOCTable1 = Worksheets("Index").ListObjects("TOCTable1")
    ReDim PDFSheets(1 To TOCTable1.DataBodyRange.Rows.Count)
    'fill up the array
    For c = 1 To UBound(PDFSheets)
        PDFSheets(c) = TOCTable1.DataBodyRange(c, 1).Value
    Next c
    Worksheets(PDFSheets).Select
    ActiveSheet.ExportAsFixedFormat xlTypePDF, strPath & strFileName
    Worksheets("Index").Select
    MsgBox "PDF file was created." & vbNewLine & "File is called Provision. It is saved on the same directory as this workbook.", , "Well Done"
    Exit Sub
   
Handle:
    If Err.Number = 9 Then
    MsgBox "It looks like a tab name was not spelled correctly. Please double check."
    Else
    MsgBox "Looks like error here. Please ensure sheets are visible..."
    End If

End Sub

Regards,

Robert

Hello Robert,

I just tested and it worked perfectly.

Thank you for the solution. Greatly appreciated.

Mike

 

[Trebor76]

Hello Robert,

I just tested and it worked perfectly.

Thank you for the solution. Greatly appreciated.

Mike

Thanks for letting us know and you're welcome