VBA to save Excel files as PDF

Question

VBA to save Excel files as PDF

Please help me with the following Excel Macro. I currently have it set up as if given a specific folder. It will either convert all the excel (*.xsl* ) inside the folder into PDF. I was able to either the active/selected sheet or all of them. 

Please see current code below:

    Sub Convert_Excel_To_PDF()

        Dim MyPath As String, FilesInPath As String

        Dim MyFiles() As String, Fnum As Long

        Dim mybook As Workbook

        Dim CalcMode As Long

        Dim sh As Worksheet

        Dim ErrorYes As Boolean

        Dim LPosition As Integer

        'Fill in the path\folder where the Excel files are

        MyPath = "C:\downloads\example_test\"

        FilesInPath = Dir(MyPath & "*.xls*")

        If FilesInPath = "" Then

            MsgBox "No files found"

            Exit Sub

        End If

        Fnum = 0

        Do While FilesInPath <> ""

            Fnum = Fnum + 1

            ReDim Preserve MyFiles(1 To Fnum)

            MyFiles(Fnum) = FilesInPath

            FilesInPath = Dir()

        Loop

        With Application

            CalcMode = .Calculation

            .Calculation = xlCalculationManual

            .ScreenUpdating = False

            .EnableEvents = False

        End With

        If Fnum > 0 Then

            For Fnum = LBound(MyFiles) To UBound(MyFiles)

                Set mybook = Nothing

                On Error Resume Next

                Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))

                On Error GoTo 0

                If Not mybook Is Nothing Then

                        LPosition = InStr(1, mybook.Name, ".") - 1

                        mybookname = Left(mybook.Name, LPosition)

                        mybook.Activate

                        'All PDF Files get saved in the directory below:

                        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _

                            "C:\downloads\example_test\" & mybookname & ".pdf", _

                            Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _

                            :=False, OpenAfterPublish:=False

                End If

                mybook.Close SaveChanges:=False

            Next Fnum

        End If

        If ErrorYes = True Then

            MsgBox "There are problems in one or more files, possible problem:" _

                 & vbNewLine & "protected workbook/sheet or a sheet/range that not exist"

        End If

        With Application

            .ScreenUpdating = True

            .EnableEvents = True

            .Calculation = CalcMode

        End With

    End Sub

I am trying to do it so that based on a table (with the name "sheet_select_table1"), it does a lookup of the name, and if it matches column A, then only use the sheet on column B and convert such specific sheet number into PDF.

For example:

If there is a file with the name "04-file1.xls" it would go through the given path and only turn into PDF sheet 1. Similarly, if there is a file "08-test2.xlsx" it would only turn into PDF sheet 2.

Also, just to clarify, the macro_file.xslm will be the one running to convert other excel files (in the given folder) into PDFs. There will be no content in the macro file other than the table indicated above, so there is no need to convert it into PDF.

If the files do not match the name, import all the sheets (which is what it is currently doing).

I think it would have to have an IF function to go over the table. 

Any help is appreciated! 

Please let me know if anything needs further clarification; again, thank you in advance!

Answer 1

If Error > 0 Then 'added
SheetNumber = 0 'added End If 'added

It is Err not Error. Change it to 
If Err > 0 Then                    'added     
  SheetNumber = 0                  'added 
End If                               'added    

See https://1drv.ms/x/s!Avg5eRPJ5YjoiD6qLCuY5jLqtAJ1?e=4jYJf2

Note:

This can go within the If Err > 0 check:

Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum)) ' copied
this will avoid opening the file when it is not to be processed

Answer 2

Awesome, it worked! Thank you for all your help.
Plus attaching the excel link/example.

I changed it within, and now it is more efficient! Thank you for the tip.

I also added ", UpdateLinks:=False" to:

Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum), UpdateLinks:=False) ' copied

Since some of the files that had links were causing some prompts and issues.

Answer 3

Thank you for the answer @Sheeloo

It is not working. I have re-copied the code plus your changes below. Please let me know if I am missing something. Since I am not getting any error or anything, it just runs and then closes the file (yet no actual changes made to the files on the list)

Sub Convert_Excel_To_PDF()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String, Fnum As Long
    Dim mybook As Workbook
    Dim CalcMode As Long
    Dim sh As Worksheet
    Dim ErrorYes As Boolean
    Dim LPosition As Integer

    'Fill in the path\folder where the Excel files are
    MyPath = "C:\downloads\example_test\"

    FilesInPath = Dir(MyPath & "*.xls*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            'Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            'On Error GoTo 0
            SheetNumber = Application.WorksheetFunction.VLookup(MyFiles(Fnum), ThisWorkbook.Worksheets("Lookup").Range("A:B"), 2, 0) 'added
            If Error > 0 Then                    'added
                SheetNumber = 0                  'added
            End If                               'added
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum)) ' copied
            On Error GoTo 0                      'copied

            'If Not mybook Is Nothing Then 'altered
            If Not mybook Is Nothing And SheetNumber > 0 Then

                LPosition = InStr(1, mybook.Name, ".") - 1
                mybookname = Left(mybook.Name, LPosition)
                mybook.Activate
                'All PDF Files get saved in the directory below:
                ' ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ 'CHANGED to below
                mybook.Worksheets(SheetNumber).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                                                                   "C:\downloads\example_test\" & mybookname & ".pdf", _
                                                                   Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
                                                                   :=False, OpenAfterPublish:=False

            End If

            mybook.Close SaveChanges:=False

        Next Fnum
    End If

    If ErrorYes = True Then
        MsgBox "There are problems in one or more files, possible problem:" _
             & vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
    End If

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

I have commented the changes you suggested so that it is easier to track the changes in a VBA editor.

If you remove all the comments it should match the same code you proposed

Also, I did name the sheet of the macro file "Lookup." where the table of columns A and B are located.

Yes, if I am able to get it to work I will mark it as it solved the problem since it would help people in the future

Answer 4

Try the code below. Additions/changes in bold...
You should move the file open inside the IF statement. not point in opening if you are not going to process.
I have used Cols A & B in Lookup sheet to get the Sheet Number

    Sub Convert_Excel_To_PDF()

        Dim MyPath As String, FilesInPath As String

        Dim MyFiles() As String, Fnum As Long

        Dim mybook As Workbook

        Dim CalcMode As Long

        Dim sh As Worksheet

        Dim ErrorYes As Boolean

        Dim LPosition As Integer

        'Fill in the path\folder where the Excel files are

        MyPath = "C:\downloads\example_test\"

        FilesInPath = Dir(MyPath & "*.xls*")

        If FilesInPath = "" Then

            MsgBox "No files found"

            Exit Sub

        End If

        Fnum = 0

        Do While FilesInPath <> ""

            Fnum = Fnum + 1

            ReDim Preserve MyFiles(1 To Fnum)

            MyFiles(Fnum) = FilesInPath

            FilesInPath = Dir()

        Loop

        With Application

            CalcMode = .Calculation

            .Calculation = xlCalculationManual

            .ScreenUpdating = False

            .EnableEvents = False

        End With

        If Fnum > 0 Then

            For Fnum = LBound(MyFiles) To UBound(MyFiles)

                Set mybook = Nothing

                On Error Resume Next SheetNumber = Application.WorksheetFunction.VLookup(MyFiles(Fnum), ThisWorkbook.Worksheets("Lookup").Range("A:B"), 2, 0) If Err > 0 Then SheetNumber = 0 End If

                Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))

                On Error GoTo 0

                If Not mybook Is Nothing And SheetNumber > 0 Then

                        LPosition = InStr(1, mybook.Name, ".") - 1

                        mybookname = Left(mybook.Name, LPosition)

                        mybook.Activate

                        'All PDF Files get saved in the directory below:

                      **mybook.Worksheets(SheetNumber).**ExportAsFixedFormat Type:=xlTypePDF, Filename:= _

                            "C:\downloads\example_test\" & mybookname & ".pdf", _

                            Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _

                            :=False, OpenAfterPublish:=False

                End If

                mybook.Close SaveChanges:=False

            Next Fnum

        End If

        If ErrorYes = True Then

            MsgBox "There are problems in one or more files, possible problem:" _

                 & vbNewLine & "protected workbook/sheet or a sheet/range that not exist"

        End If

        With Application

            .ScreenUpdating = True

            .EnableEvents = True

            .Calculation = CalcMode

        End With

    End Sub

Answer 5

Dear juano6,

Good day!

Thanks for posting in Microsoft Community.

We would love to help you on your query about VBA code, however, our team focuses on general query, for example, installation and activation issue of Office 365 products. The situation you mentioned is related to VBA code, you can to refer to this article: Office VBA support and feedback | Microsoft Docs to go to Stack Overflow by using the VBA tag, along with any other relevant tags as there are also many experienced engineers and experts in the forums there.

Disclaimer*: Microsoft provides no assurances and/or warranties, implied or otherwise, and is not responsible for the information you receive from the third-party linked sites, or any support related to technology.*

At the same time, we will also keep this thread open, so other Community members and Experts can also share their suggestions and inputs.

Thank you for your cooperation and understanding!

Best Regards,

George