Copy a range of Cells inside a loop to Powerpoint-CodePudding

I have a data set that Im trying to tur into automatic PowerPoint slides.The number of rows changes weekly so the range has to be variable. this is how my data looks like

So far i've been able to create a slide for each title, copy the headers as an image and add copy the value of the 16th cell to each slide, but now i want to copy the values of each row its looping as an image but only from columns B to O. So that the First slide would have (B1:O1) The second would have (B2:O2) But i haven figured out how to do it. I wanted to use "rowShape" as the name for the rows image Here's my code so far:

Option Explicit
Sub Data_to_PowerPoint()

    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim ExcelRow As Range
    Dim CellRange As Range
    Dim SlideText As Variant
    Dim lr As Long
    Dim hdr As Range
    Dim myShape As Object
    Dim rowShape As Object

    'The first range of cells in the table.
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    Set CellRange = Sheets("TicketSummary").Range("A1:A" & lr)

    'Determine header range.
    Set hdr = Sheets("TicketSummary").Range("B1:O1")

    'Look for existing powerpoint instance
    On Error Resume Next
    Set newPowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

    'Create a PowerPoint
    If newPowerPoint Is Nothing Then

        Set newPowerPoint = New PowerPoint.Application

    End If

    'Setup the presentation in PowerPoint
    If newPowerPoint.Presentations.Count = 0 Then

        newPowerPoint.Presentations.Add

    End If

    'Make PowerPoint visible
    newPowerPoint.Visible = True

    'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
    For Each ExcelRow In CellRange



        'Add a new slide
        newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count   1, ppLayoutText
        newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

        'Create the body text for the slide
        SlideText = Cells(ExcelRow.Row, 16)

        'Input the title of the slide
        activeSlide.Shapes(1).TextFrame.TextRange.Text = ExcelRow.Value

        'Input the body text for the slide
        activeSlide.Shapes(2).TextFrame.TextRange.Text = SlideText
        
        
        'Copy Header.
         hdr.Copy
         
        'Paste header to PowerPoint and position
        activeSlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
        Set myShape = activeSlide.Shapes(activeSlide.Shapes.Count)
  
       'Set position:
        myShape.Left = 60
        myShape.Top = 152
      
   Next

   Set activeSlide = Nothing
   Set newPowerPoint = Nothing

End Sub

CodePudding user response：

Option Explicit

Sub Data_to_PowerPoint()

    Dim pp As PowerPoint.Application, pps As PowerPoint.Slide
    Dim lr As Long, i As Long, n As Long
    
    'Look for existing powerpoint instance
    On Error Resume Next
    Set pp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

    'Create a PowerPoint
    If pp Is Nothing Then
        Set pp = New PowerPoint.Application
    End If
    'Setup the presentation in PowerPoint
    If pp.Presentations.Count = 0 Then
        pp.Presentations.Add
    End If
     'Make PowerPoint visible
    pp.Visible = True
    
    'The first range of cells in the table.
    With Sheets("TicketSummary")
     
        lr = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 2 To lr
            ' create slide
            pp.ActivePresentation.Slides.Add i - 1, ppLayoutText
            pp.ActiveWindow.View.GotoSlide i - 1
            Set pps = pp.ActivePresentation.Slides(i - 1)

           'Input the title of the slide
            pps.Shapes(1).TextFrame.TextRange.Text = .Cells(i, "A")
            
            'Input the body text for the slide
            pps.Shapes(2).TextFrame.TextRange.Text = .Cells(i, "P") ' col 16
            
            ' copy header
            ' Paste to PowerPoint and position
            ' paste 2 = ppPasteEnhancedMetafile 3 ppPasteMetafilePicture
            n = pps.Shapes.Count
            .Range("B1:O1").Copy
            Application.Wait Now   TimeSerial(0, 0, 1) ' 1 second wait
            pps.Shapes.PasteSpecial DataType:=2
            
            ' wait for shape to be pasted
            Do
                DoEvents
            Loop Until pps.Shapes.Count > n
            Application.CutCopyMode = False
            
            'Set position:
            With pps.Shapes(n   1)
                .Left = 60
                .Top = 182
            End With
            
            ' copy row
            n = pps.Shapes.Count
            .Range("B1:O1").Offset(i - 1).Copy
            Application.Wait Now   TimeSerial(0, 0, 1) ' 1 second wait
            pps.Shapes.PasteSpecial DataType:=2
            
            ' wait for shape to be pasted
            Do
                DoEvents
            Loop Until pps.Shapes.Count > n
            Application.CutCopyMode = False
            
            'Set position:
            With pps.Shapes(n   1)
                .Left = 60
                .Top = 202
            End With
              
        Next
    End With
    MsgBox lr - 1 & " slides created"
    
End Sub