Powerpoint Automation – Merge with Excel

Sub PopulateExistingTable()
Dim pptApp As Object
Dim pres As Object
Dim slide As Object
Dim tableShape As Object
Dim excelApp As Object
Dim excelWorkbook As Object
Dim excelSheet As Object
Dim row As Integer
Dim imagePath As String
Dim imageRectangle As Object

Dim excelFilePath As String
excelFilePath = "d:\mergedata\MDatay.xlsx"

Set excelApp = CreateObject("Excel.Application")
excelApp.Visible = False
Set excelWorkbook = excelApp.Workbooks.Open(excelFilePath)
Set excelSheet = excelWorkbook.Sheets(1)

Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True

If pptApp.Presentations.Count > 0 Then
    Set pres = pptApp.ActivePresentation
Else
    MsgBox "No PowerPoint presentation is open!", vbExclamation
    Exit Sub
End If

row = 2
Do While excelSheet.Cells(row, 1).Value <> ""
    Set slide = pres.Slides(1).Duplicate

    Set tableShape = Nothing
    Dim shp As Object
    For Each shp In slide.Shapes
        If shp.HasTable Then
            Set tableShape = shp
            Exit For
        End If
    Next shp

    If Not tableShape Is Nothing Then
        tableShape.Table.Cell(2, 1).Shape.TextFrame.TextRange.Text = excelSheet.Cells(row, 1).Value
        tableShape.Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = excelSheet.Cells(row, 2).Value
    Else
        MsgBox "No table found on the slide!", vbExclamation
        Exit Sub
    End If

    imagePath = excelSheet.Cells(row, 3).Value
    If Len(imagePath) > 0 And Dir(imagePath) <> "" Then
        On Error Resume Next
        Set imageRectangle = slide.Shapes("ImageRectangle")
        On Error GoTo 0

        If Not imageRectangle Is Nothing Then
            imageRectangle.Fill.UserPicture imagePath
        Else
            MsgBox "Rectangle shape not found!", vbExclamation
        End If
    Else
        MsgBox "Invalid image path for row " & row, vbExclamation
    End If

    row = row + 1
Loop

excelWorkbook.Close False
excelApp.Quit

Set excelSheet = Nothing
Set excelWorkbook = Nothing
Set excelApp = Nothing

MsgBox "Slides created and populated successfully!", vbInformation

End Sub

Comments

Leave a Reply

Your email address will not be published. Required fields are marked *