Pasting Excel Range Into Powerpoint Notes section

[stiveralex]

So I am trying to paste a column into powerpoint slide notes but it only grabs one cell and pastes it into the first slide and will not go to the next slide and paste the next cell into the notes of the 2nd slide.


Sub Notes()


Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape
Dim strNotes As String
' Amended Dim Sh As Shape to...
Dim Sh As PowerPoint.Shape


'launch powerpoint application
Set PPTApp = New PowerPoint.Application
PPTApp.Activate
'open powerpoint presentation for macmahon off the intranet
Set PPTPres = PPTApp.Presentations.Open("C:\Users\BZFST3\Documents\Change Management\Code for Slides\FINAL\Template.pptx")


Sheets("Raw Data").Select
Range("M2:M26").Select


Set PPTSlide = PPTPres.Slides(1)


On Error GoTo errHandler




Do While ActiveCell.Value <> ""
ActiveCell.Copy
With PPTSlide
If PPTSlide.NotesPage.Shapes.Count = 0 Then 'If no shapes to take Notes then add a shape first
PPTSlide.NotesPage.Shapes.AddShape msoShapeRectangle, 0, 0, 0, 0
Sh = PPTSlide.NotesPage.Shapes(1)
'Code change here - did not recognize Sh.TextFrame.TextRange.Text.Paste
'So, I set the object text to value of the active cell and seemed to do the trick


Sh.TextFrame.TextRange.Text = ActiveCell.Value
Else 'has shapes, so see if they take text
For Each Sh In PPTSlide.NotesPage.Shapes
If Sh.HasTextFrame Then
'Code change here - did not recognize Sh.TextFrame.TextRange.Text.Paste
'So, I set the object text to value of the active cell and seemed to do the trick
Sh.TextFrame.TextRange.Text = ActiveCell.Value
End If
Next Sh
End If
End With
Set PPTSlide = PPTPres.Slides.Add(PPTPres.Slides.Count + 1, ppLayoutText)
ActiveCell.Offset(1, 0).Select
Loop
Exit Sub
errHandler:
MsgBox Err.Number & vbTab & Err.Description, vbCritical, "Error"
End Sub