VBA: save Excel files as PDF

Question

VBA to save 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. Right now, 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

This should do what you want. Feel free to change the code to suit your needs.

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:\Users\ryans\Desktop\in\"
 
    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 XLSX Files get saved in the directory below:
                    ActiveWorkbook.SaveAs Filename:="C:\Users\ryans\Desktop\out\" & mybookname & ".pdf"
                        
            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