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

Question

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

Answer 1

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