Data Transfer from Excel to PowerPoint and getting PDF file of PPT

[Muhammad Nasir Mahmood]

I have two files: one Excel file and one PowerPoint file. I am exporting data from Excel to PowerPoint and then generating a PDF file for each record.

The VBA code is working fine, but there is one issue. It simply saves the document as a PDF.

However, I want to export the document from PowerPoint using the following steps:

1. Use the Export function.
2. Select Create PDF/XPS Document.
3. Click Create PDF/XPS.
4. In the Options, uncheck the box for Document structure tags for accessibility (this option is checked by default).

When the Document structure tags for accessibility option is checked, the word "YES" appears in front of TAGGED PDF.
When the option is unchecked, the word "NO" is displayed in front of TAGGED PDF.

Please help to resolve the issue.

Thanks

NOTE: I AM NOT AN EXPERT IN CODING

Code is:
Sub ExportPPTtoPDF()
Dim pptApp As Object
Dim pptPres As Object
Dim pptSlide As Object
Dim shape As Object
Dim excelSheet As Worksheet
Dim row As Integer
Dim pdfPath As String
Dim pptFilePath As String
Dim fileName As String
Dim folderPath As String
Dim selectedFolder As String
Dim shapeName As String
Dim slideIndex As Integer
Dim slide As Object
Dim shapeFound As Boolean

' Set Excel Worksheet "Do not delete"
Set excelSheet = ThisWorkbook.Sheets("Do not delete") ' Sheet name "Do not delete"

' Ask user to open PowerPoint file
pptFilePath = Application.GetOpenFilename("PowerPoint Files (*.pptx), *.pptx", , "Select PowerPoint File")

If pptFilePath = "False" Then Exit Sub ' Exit if user cancels file dialog

' Open PowerPoint application and the presentation
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Open(pptFilePath)

' Ask user to select the destination folder to save PDF
selectedFolder = Application.GetSaveAsFilename("Select destination to save PDF", , , "PDF Files (*.pdf), *.pdf")

If selectedFolder = "False" Then Exit Sub ' Exit if user cancels file dialog

folderPath = Left(selectedFolder, InStrRev(selectedFolder, "\") - 1)

' Loop through each row starting from row 2 (assuming row 1 is header)
For row = 2 To excelSheet.Cells(excelSheet.Rows.Count, "B").End(xlUp).row
' Get the name of the PDF from column Q
fileName = excelSheet.Cells(row, 17).Value ' Column Q

' Loop through all slides in the PowerPoint presentation
For slideIndex = 1 To pptPres.Slides.Count
Set pptSlide = pptPres.Slides(slideIndex)

' Loop through each shape on the current slide
For Each shape In pptSlide.Shapes
' Match the shape name case-insensitively
If LCase(shape.Name) = "data1" Then
shape.TextFrame.TextRange.Text = excelSheet.Cells(row, 2).Value ' Data1 (B2)
ElseIf LCase(shape.Name) = "data2" Then
shape.TextFrame.TextRange.Text = excelSheet.Cells(row, 3).Value ' Data2 (C2)
ElseIf LCase(shape.Name) = "data3" Then
shape.TextFrame.TextRange.Text = excelSheet.Cells(row, 4).Value ' Data3 (D2)
ElseIf LCase(shape.Name) = "data4" Then
shape.TextFrame.TextRange.Text = excelSheet.Cells(row, 5).Value ' Data4 (E2)
End If
Next shape
Next slideIndex

' Export the presentation to PDF with the selected file name and path
pptPres.SaveAs folderPath & "\" & fileName & ".pdf", 32 ' Save as PDF (32 is for PDF format)
' Message to confirm PDF saved
MsgBox "PDF saved as: " & folderPath & "\" & fileName & ".pdf"
Next row

' Close PowerPoint presentation without saving
pptPres.Close
pptApp.Quit
End Sub

 

[Sequoyah]

Hi Muhammad,
Please use Code Tags when posting VBA code to make your code easier to read. Instead of using 'Save As', try 'ExportAsFixedFormat As'. First Add reference to Powerpoint object library, from Excel press Alt+F11 to open the VBE. Then do Tools > References... then scroll down to the "Microsoft PowerPoint xx.0 Object Library" and check the box. OK.
To learn more about the Presentation.ExportAsFixedFormat method in PowerPoint and its parameters see this link

Presentation.ExportAsFixedFormat method (PowerPoint)

Office VBA reference topic

learn.microsoft.com

here is my suggestion, i made some slight changes to your code

Sub ExportPPT2PDFm()
'https://www.mrexcel.com/board/threads/data-transfer-from-excel-to-powerpoint-and-getting-pdf-file-of-ppt.1267369/
    
Dim pptApp          As Object, pptPres As Presentation, pptSlide As Object, shape As Object
Dim pptFilePath     As String, MyPDF As String
Dim fileDialog      As fileDialog
Dim selectedFolder
Dim row             As Integer, slideIndex As Integer
Dim excelSheet      As Worksheet

Set excelSheet = ThisWorkbook.Sheets("Do Not delete")        ' Sheet name "Do not delete"

Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)

With fileDialog
    .Title = "Select PowerPoint File"
    .Filters.Add "PowerPoint files", "*.ppt; *.pptx", 1
    .AllowMultiSelect = False
    If .Show = -1 Then
        pptFilePath = .SelectedItems(1)
    Else
        ' MsgBox "No file selected.", vbExclamation
        Exit Sub
    End If
End With

On Error Resume Next
Set pptApp = CreateObject("PowerPoint.Application")
On Error GoTo 0

If pptApp Is Nothing Then
    ' MsgBox "...", vbCritical
    Exit Sub
End If

' Open PowerPoint file
On Error Resume Next
Set pptPres = pptApp.Presentations.Open(pptFilePath)
On Error GoTo 0

If pptPres Is Nothing Then
    ' MsgBox "...", vbCritical
    pptApp.Quit
    Set pptApp = Nothing
    Exit Sub
End If

With Application.fileDialog(msoFileDialogFolderPicker)
    .ButtonName = "Select"
    If .Show = -1 Then        ' if OK is pressed
    selectedFolder = .SelectedItems(1)
Else
    pptPres.Close
    pptApp.Quit
    Exit Sub
End If
End With

' Loop through each row starting from row 2 (assuming row 1 is header)
For row = 2 To excelSheet.Cells(excelSheet.Rows.Count, "B").End(xlUp).row
    ' Get the name of the PDF from column Q
    MyPDF = excelSheet.Cells(row, 17).Value        ' Column Q
    
    ' Loop through all slides in the PowerPoint presentation
    For slideIndex = 1 To pptPres.Slides.Count
        Set pptSlide = pptPres.Slides(slideIndex)
        
        ' Loop through each shape on the current slide
        For Each shape In pptSlide.Shapes
            ' Match the shape name case-insensitively
            If LCase(shape.Name) = "data1" Then
                shape.TextFrame.TextRange.Text = excelSheet.Cells(row, 2).Value        ' Data1 (B2)
            ElseIf LCase(shape.Name) = "data2" Then
                shape.TextFrame.TextRange.Text = excelSheet.Cells(row, 3).Value        ' Data2 (C2)
            ElseIf LCase(shape.Name) = "data3" Then
                shape.TextFrame.TextRange.Text = excelSheet.Cells(row, 4).Value        ' Data3 (D2)
            ElseIf LCase(shape.Name) = "data4" Then
                shape.TextFrame.TextRange.Text = excelSheet.Cells(row, 5).Value        ' Data4 (E2)
            End If
        Next shape
    Next slideIndex
    
    ' Export the presentation to PDF with the selected file name and path
    
    pptPres.ExportAsFixedFormat selectedFolder & "\" & MyPDF & ".pdf", _
                                ppFixedFormatTypePDF, ppFixedFormatIntentPrint, msoCTrue, ppPrintHandoutHorizontalFirst, _
                                ppPrintOutputSlides, msoFalse, , ppPrintAll, , False, False, False, False, False
    
    ' Message to confirm PDF saved
    MsgBox "PDF saved as: " & selectedFolder & "\" & MyPDF & ".pdf"
Next row
pptPres.Close
pptApp.Quit

Set pptPres = Nothing
Set pptApp = Nothing

End Sub