Excel to ppt with pictures in the cells

0
votes

I am creating a presentation from an excel document that will repeat the same data on every slide. When the excel is updated, I would like to be able to refresh the ppt. by running the macro. The text is copying over and displaying correctly on the slides, but I am having trouble with the pictures located in the cells on the excel sheet. Is there a way to have the pictures in the cell copy and paste into each slide as they are created and if not, what is the best approach to achieve this?

Sub Create_Deck()
'create slide for each name in list
'fill two text boxes
Dim myPT As Presentation
Dim xlApp As Object
Dim wbA As Object
Dim wsA As Object
Dim myList As Object
Dim myRng As Object
Dim i As Long
Dim col01 As Long
Dim col02 As Long
Dim col03 As Long
Dim col04 As Long
Dim col05 As Long
Dim col06 As Long
Dim col07 As Long
Dim col08 As Long
Dim col09 As Long
Dim col10 As Long
Dim col11 As Long
Dim col12 As Long


'columns with text for slides
col01 = 2
col02 = 3
col03 = 4
col04 = 5
col05 = 6
col06 = 7
col07 = 8
col08 = 9
col09 = 11
col10 = 15
col11 = 14
col12 = 1

On Error Resume Next
 Set myPT = ActivePresentation
 Set xlApp = GetObject(, "Excel.Application")
 Set wbA = xlApp.ActiveWorkbook
 Set wsA = wbA.ActiveSheet
Set myList = wsA.ListObjects(1)
On Error GoTo errHandler

If Not myList Is Nothing Then

  Set myRng = myList.DataBodyRange

  For i = 1 To myRng.Rows.Count
      With myPT
        'Copy first slide, paste after last slide
         .Slides(1).Copy
         .Slides.Paste (myPT.Slides.Count + 1)
  
         'change text in 1st textbox
         .Slides(.Slides.Count) _
           .Shapes(1).TextFrame.TextRange.Text _
             = myRng.Cells(i, col01).Value
     
         'change text in 2nd textbox
         .Slides(.Slides.Count) _
           .Shapes(2).TextFrame.TextRange.Text _
             = myRng.Cells(i, col02).Value
         
         'change text in 3rd textbox
        .Slides(.Slides.Count) _
           .Shapes(3).TextFrame.TextRange.Text _
             = myRng.Cells(i, col03).Value
         
        'change text in 4th textbox
         .Slides(.Slides.Count) _
           .Shapes(4).TextFrame.TextRange.Text _
             = myRng.Cells(i, col04).Value
         
        'change text in 5th textbox
         .Slides(.Slides.Count) _
           .Shapes(5).TextFrame.TextRange.Text _
             = myRng.Cells(i, col05).Value
         
        'change text in 6th textbox
         .Slides(.Slides.Count) _
           .Shapes(6).TextFrame.TextRange.Text _
             = myRng.Cells(i, col06).Value
         
             'change text in 7th textbox
         .Slides(.Slides.Count) _
           .Shapes(7).TextFrame.TextRange.Text _
             = myRng.Cells(i, col07).Value
         
         'change text in 8th textbox
         .Slides(.Slides.Count) _
            .Shapes(8).TextFrame.TextRange.Text _
             = myRng.Cells(i, col08).Value
         
             'change text in 9th textbox
         .Slides(.Slides.Count) _
           .Shapes(9).TextFrame.TextRange.Text _
             = myRng.Cells(i, col09).Value
         
            'change text in 10th textbox
         .Slides(.Slides.Count) _
           .Shapes(10).TextFrame.TextRange.Text _
             = myRng.Cells(i, col10).Value
         
          'change text in 11th textbox
         .Slides(.Slides.Count) _
           .Shapes(11).TextFrame.TextRange.Text _
             = myRng.Cells(i, col11).Value
          
        Adds Picture
          .Slides(.Slides.Count) _
           .Shapes(12).TextFrame.TextRange.Text _
             = myRng.Cells(i, col12).Value
  
      End With
  Next
Else
  MsgBox "No Excel table found on active sheet"
  GoTo exitHandler
End If

exitHandler:
  Exit Sub
errHandler:
  MsgBox "Could not complete slides"
  Resume exitHandler
End Sub
excelvbapowerpoint