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
Leave a Reply