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

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
4,004
This version includes titles, subtitles and custom image positioning:

Code:
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
 
Last edited:

Some videos you may like

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

onthegreen03

Board Regular
Joined
Jun 30, 2016
Messages
61
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

Well-known Member
Joined
Oct 30, 2011
Messages
4,004
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.




Code:
' 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
 
Last edited:

onthegreen03

Board Regular
Joined
Jun 30, 2016
Messages
61
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

Board Regular
Joined
Jun 30, 2016
Messages
61
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

Well-known Member
Joined
Oct 30, 2011
Messages
4,004
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…


Code:
' 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

Board Regular
Joined
Jun 30, 2016
Messages
61
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

Well-known Member
Joined
Oct 30, 2011
Messages
4,004
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,102,889
Messages
5,489,551
Members
407,700
Latest member
SimpleJuan

This Week's Hot Topics

  • Timer in VBA - Stop, Start, Pause and Reset
    [CODE=vba][/CODE] Option Explicit Dim CmdStop As Boolean Dim Paused As Boolean Dim Start Dim TimerValue As Date Dim pausedTime As Date Sub...
  • how to updates multiple rows in muliselect listbox
    Hello everyone. I need help with below code. code is only chaning 1st row in mulitiselect list box. i know issue with code...
  • Delete Row from Table
    I am trying to delete a row from a table using VBA using a named range to find what I need to delete. My Range is finding the right cell. In the...
  • Assigning to a variable
    I have a for each block where I want to assign the value in column 5 of the found row to the variable Serv. [CODE=vba] For Each ws In...
  • Way to verify information
    Hi All, I don't know what to call this formula, and therefore can't search. I have a spreadsheet with information I want to reference...
  • Active Cell Address – Inactive Sheet
    How to use VBA to get the cell address of the active cell in an inactive worksheet and then place that cell address in a location on the current...
Top