Macro to open Powerpoint and paste ranges from Excel - Troubleshoot error in code

[onthegreen03]

Hi -

I have some code that I copied from other users on line which opens PP (Procedure1) and then copies and pastes ranges from Excel (Procedure2) into that PP. When I run the code below it opens the Powerpoint no problem but it breaks down in Procedure2. Can someone help me figure out what needs to be fixed in Procedure 2 so that it copies/pastes the selected range into the PP opened in Procedure1? The code breaks at the "Add a slide to the presentation" step. Hopefully this makes sense. Many thanks for your help!

---------------------------------------------------------------------

Sub RunAllMacros()
Procedure1
Procedure2
End Sub

Sub Procedure1()

Dim objPPT As Object

Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True

objPPT.Presentations.Open "C:\users\migreen\AppData\Roaming\Microsoft\Templates\Blank.potx"

End Sub

Sub Procedure2()

Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object

'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("A1:C12")

'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly

'Copy Excel Range
rng.Copy

'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

'Set position:
myShape.Left = 66
myShape.Top = 152

'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate

'Clear The Clipboard
Application.CutCopyMode = False

End Sub

 

[Worf]

This version includes titles, subtitles and custom image positioning:

Dim objppt As PowerPoint.Application
Sub RunAllMacros()
Procedure1
Procedure2
MsgBox "Success!", 64
End Sub

Sub Procedure1()
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "c:\users\public\template.potx" ' your path here
End Sub

Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, mySlide As Object, _
myShape As Object, sar, i%, rad, wa, ha, tit, subtit, la, ta
la = Array(10, 20, 30, 40, 50, 60)                                      ' left
ta = Array(70, 75, 80, 85, 90, 95)                                      ' top
sar = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6")
tit = Array("title1", "title2", "title3", "title4", "title5", "title6")
subtit = Array("subtitle1", "subtitle2", "subtitle3", "subtitle4", "subtitle5", "subtitle6")
rad = Array("B7:T33", "B7:K33", "B3:P39", "B3:P39", "B3:P39", "B2:P36") ' ranges
wa = Array(0.8, 0.8, 0.9, 0.9, 0.9, 0.9) ' percentages of slide width and height
ha = Array(0.8, 0.8, 0.8, 0.8, 0.8, 0.8)
Set mypres = objppt.ActivePresentation
Do While mypres.Slides.Count > 1
    mypres.Slides(mypres.Slides.Count).Delete
Loop
Set mySlide = objppt.ActiveWindow.View.Slide
For i = LBound(sar) To UBound(sar)
    mySlide.Shapes(1).TextFrame.TextRange.Text = tit(i)
    mySlide.Shapes(2).TextFrame.TextRange.Text = subtit(i)
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.LockAspectRatio = 0
    myShape.Left = la(i)
    myShape.Top = ta(i)
    myShape.Width = wa(i) * mypres.PageSetup.SlideWidth                     ' set picture size
    myShape.Height = ha(i) * mypres.PageSetup.SlideHeight
    Set mySlide = mypres.Slides.Add(mypres.Slides.Count + 1, ppLayoutTitle) ' title and subtitle
Next
If mypres.Slides.Count > 3 Then mypres.Slides(mypres.Slides.Count).Delete
objppt.Visible = 1
objppt.Activate
Application.CutCopyMode = False ' clear clipboard
mypres.SaveAs "c:\users\public\finaldeck.pptx"
End Sub

 

[onthegreen03]

Very cool worf. Will try this on Monday. Can't wait to see how it works. Thanks!!!!

 

[onthegreen03]

Hey Worf - I tried the new PP code and something weird is happening. It starts to run and opens up that blank PP template and for the first slide everything looks okay. But starting with the second slide it is pasting the Excel ranges into one of our standard company cover slides. I'm not sure where it is grabbing that from but slides 2-6 are all pasted on a cover slide. Normally the code just copied that first (blank) slide and used it all the way through. The ranges appear to be copying correctly and sizing looks good. Also, on the first slide (that appears on the correct slide format) I do see the main title box but not the subtitle. Maybe we can address that issue after you first try and figure out why this new code is bringing in a cover slide. I can send you screen shots if that is helpful. Thanks!

 

[Worf]

It is probably coming from the layout gallery. Please use the code below to check that and tell me which of your options I should pick.

' PowerPoint module
Sub XRay()
Dim i%, sm
Set sm = ActivePresentation.Designs(1).SlideMaster
For i = 1 To sm.CustomLayouts.Count
    MsgBox sm.CustomLayouts(i).Name, 64, "#" & i
Next
End Sub

 

[onthegreen03]

Sorry you lost me. What do you need me to do with that code? Run it in Excel? PP? What options will I be sending you? Can you send me more detailed steps so I can execute it correctly.

 

[onthegreen03]

Hi Worf -

I got very lucky and somehow fixed the problem with the cover slide being added. I went back to the old code (before you added array titles, etc.) and compared it to the new code. I changed the line below from the new code based on the old code:

Set mySlide = mypres.Slides.Add(mypres.Slides.Count + 1, ppLayoutTitle)

Changed to

Set mySlide = mypres.Slides.Add(mypres.Slides.Count + 1, 11)

By changing pplayoutTitle to 11 it appears to fix the problem (I have no idea why). But now the Excel ranges are correctly pasting to blank PP slides. Sizing and positioning is working. All good there.

Next problem. I noticed that the Title is being added to each slide (Title1, Title2, etc) but not the subtitle. Any idea how to fix that? Ideally I would like the Title and right below the subtitle. Also, if there is a way to set the font size so the subtitle is a bit smaller that would be cool. If not no big deal.

Thanks!

 

[Worf]

That’s because ppLayoutTitle=1, includes title and subtitle; ppLayoutTitleOnly=11, as the constant name implies, only title.
I will write code that inserts the subtitle manually, with custom font and position.
One thing that will help me is knowing your slide structure; please copy the code below to the current presentation with the subtitle issue, run it and report back the results; you should get names like title, placeholder, footer, header…

' this goes at a PowerPoint module
Sub CountShapes()
Dim i%, slnumber%, sl As Slide
slnumber = 2                                    ' choose a slide number
Set sl = ActivePresentation.Slides(slnumber)
For i = 1 To sl.Shapes.Count
    MsgBox sl.Shapes(i).Name                    ' I need these names...
Next
End Sub

 

[onthegreen03]

Okay. I ran the code and here is what returned:

Title 7 <hit Ok="">
Slide Number Placeholder 3 <hit Ok="">
Slide Number Placeholder 3 <hit Ok="">

That was it. Nothing about header or footer, and yes that slide number message did repeat. Not sure this matters but in that .potx file I have only 1 slide showing but eventually I would like to add a cover slide. So when the macro runs it pastes the Excel ranges starting with slide 2. That is a question for another day.

Let me know if you need anything else as it relates to this current issue.</hit></hit></hit>

 

[Worf]

I’ve been thinking and manually adding subtitles is not the best solution. Instead, we can initially add a title slide, which will have the title and subtitle placeholders, and later change its layout, after inserting the desired text.

To do that, I need you to run the code at post #44, it’s a PowerPoint macro. It will give me your layout options, which you can see by clicking the layout button as shown at that same post.

 

[onthegreen03]

Ok. Will run first thing in the AM.