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

 

[onthegreen03]

Okay Worf ... here are the results of the code in thread #44. A number appears at the top of each message box which I've detailed below:

#1 = Title Slide
#2 = 1_Title Slide
#3 = Title and Content
#4 = Two Content
#5 = Comparison
#6 = Title Only
#7 = Blank

Let me know what else you need and thanks for working on this!

 

[Worf]

This worked for me:

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, sl 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 sl = objppt.ActiveWindow.View.Slide
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(2)
For i = LBound(sar) To UBound(sar)
    sl.Shapes(1).TextFrame.TextRange.Text = tit(i)
    sl.Shapes(2).TextFrame.TextRange.Text = subtit(i)
    sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(6)        ' title only
    sl.Shapes(1).TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
    sl.Shapes(1).Top = 50
    sl.Shapes(1).Left = 40
    sl.Shapes(2).Top = sl.Shapes(1).Top + sl.Shapes(1).Height + 5           ' position subtitle
    sl.Shapes(2).Left = 40
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set myShape = sl.Shapes(sl.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 sl = 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]

Worf - I tried the code and it stops at the code in RED below. That is the same line that trips me up every once in a while ... not sure why. I was playing around with the .potx template yesterday and had to resave it, but the code opens up PP with no issue so I don't think that is what is impacting this error. I feel we are soooooo close!

Sub RunAllMacros()
Procedure1
Procedure2
MsgBox "Success!", 64
End Sub
Sub Procedure1()
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "M:\Forecasting\Models\2016\Data Summary\E2P\Blank.potx" ' your path here
End Sub
Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, sl 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 sl = objppt.ActiveWindow.View.Slide
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(2)
For i = LBound(sar) To UBound(sar)
sl.Shapes(1).TextFrame.TextRange.Text = tit(i)
sl.Shapes(2).TextFrame.TextRange.Text = subtit(i)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(6) ' title only
sl.Shapes(1).TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
sl.Shapes(1).Top = 50
sl.Shapes(1).Left = 40
sl.Shapes(2).Top = sl.Shapes(1).Top + sl.Shapes(1).Height + 5 ' position subtitle
sl.Shapes(2).Left = 40
Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
rng.Copy
sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
Set myShape = sl.Shapes(sl.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 sl = 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]

Worf - Disregard that last post ... I figured out the issue. I was missing the DIM code in the very beginning ... once I added that the code ran all the way through. I see the title and subtitle boxes so I'll just need to work on the placement. My goal today is to work on the code and get the placements and sizes all set. I'll send you one more post before the end of the day with a list of questions/requests. For example I'd like the title and subtitle text to be right aligned (not left). But let me work through the code today so I only send you one list of follow ups as opposed to several posts. THANKS!! This looks great and we are sooooo close to getting it done.

 

[onthegreen03]

Okay Worf. I spent some time working with the code and it works great! Below is a final list of "things to fix". I've pasted my current code so you can work off of the latest version ... I changed some of the settings to get the correct placement of the title boxes.

Here it goes:

1. I see that the title box and subtitle box are 2 separate text boxes. Is it possible to have the subtitle come in right below the title in the same text box? If not this is not a deal breaker ... just curious if possible and how hard it would be to change the code at this point.

2. The subtitle text is black font color .... can you make it white and also italicize it?

3. The subtitle text has a bullet point .... can you remove the bullet point?

4. The actual subtitle text box comes in much shorter in length. Can you make it wider so I can fit a longer string of text? Or will it fit longer text automatically? I didn't test that yet. The title page comes in at the right length.

5. Can you "Top" align the title text? I was able to figure out how to right align so I just need the title to be top aligned. No changes needed to the subtitle here.

6. Okay here is the "challenging one" .... I know you like challenges. For some reason on the very first slide the subtitle text box is not being created, but it appears like there is a slide # text box at the top. (It just has a #1 in the box and does not say "subtitle".) Slides 2-6 all have the subtitle text box so it's just slide 1 with this problem. Do you see this same thing? Maybe it is something in my slide master settings that I need to change?

7. Last one. If I were to add a cover slide to that .potx template could you change the code so that the pasting starts with slide #2? If you want to try that before attempting to troubleshoot and fix issue #6 above let me know. Perhaps by starting with slide #2 it will automatically fix that problem with the missing subtitle box. If you want to fix #6 let's leave this for last and perhaps change after all of the other issues are resolved.

Thanks again!

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 "M:\Forecasting\Models\2016\Data Summary\E2P\Blank.potx" ' your path here
End Sub
Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, sl 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 sl = objppt.ActiveWindow.View.Slide
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(2)
For i = LBound(sar) To UBound(sar)
sl.Shapes(1).TextFrame.TextRange.Text = tit(i)
sl.Shapes(2).TextFrame.TextRange.Text = subtit(i)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(6) ' title only
sl.Shapes(1).TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
sl.Shapes(1).Top = 7
sl.Shapes(1).Left = 63
sl.Shapes(2).Top = sl.Shapes(1).Top + sl.Shapes(1).Height - 30 ' position subtitle
sl.Shapes(2).Left = 608
Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
rng.Copy
sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
Set myShape = sl.Shapes(sl.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 sl = 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

 

[Worf]

1) It’s possible, but considering the different formatting required, I would stick with separate boxes, which yield the same end result.
Items #2 to #5, see below.

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, sl 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 sl = objppt.ActiveWindow.View.Slide
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(2)
For i = LBound(sar) To UBound(sar)
    sl.Shapes(1).TextFrame.TextRange.Text = tit(i)
    sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop                ' #5
    sl.Shapes(2).TextFrame.TextRange.Text = subtit(i)
    sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(6) ' title only
    With sl.Shapes(1)
        .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
        .Top = 7
        .Left = 63
    End With
    With sl.Shapes(2)
        .Top = sl.Shapes(1).Top + sl.Shapes(1).Height - 30              ' position subtitle
        .Left = 608
        .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
        .TextFrame.TextRange.Font.Italic = msoTrue                      ' #2
        .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse          ' #3
        .Width = mypres.PageSetup.SlideWidth * 0.8                      ' #4
    End With
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set myShape = sl.Shapes(sl.Shapes.Count)
    With myShape
        .LockAspectRatio = 0
        .Left = la(i)
        .Top = ta(i)
        .Width = wa(i) * mypres.PageSetup.SlideWidth                    ' set picture size
        .Height = ha(i) * mypres.PageSetup.SlideHeight
    End With
    Set sl = 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

 

[Worf]

Concerning item#6:

- I get subtitles on all six slides, but it’s my test template, not yours.
- Do you still see this behavior with the newest code?
- Is your template confidential? Could you post a link to it or email me? This would save some time.
- Please run the code below for layout numbers 1,2,6,7 and report the results; based on post #51 they seem to be the interesting ones.

' PowerPoint module
Sub ShapesInLayout()
Dim ln%, sl As Slide, c%, i%
ln = 2                                                          ' layout number
Set sl = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ln)
c = sl.Shapes.Count
For i = 1 To c
    MsgBox sl.Shapes(i).Name, 64, "*" & sl.CustomLayout.Name & "*" & _
    " Shapes ( " & i & " of " & c & ")"
Next
End Sub

 

[Worf]

At the end of this version, a cover slide is added, as per item #7:

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:\accounts\orange.potx" ' your path here
End Sub


Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, sl 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 sl = objppt.ActiveWindow.View.Slide
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(2)
For i = LBound(sar) To UBound(sar)
    sl.Shapes(1).TextFrame.TextRange.Text = tit(i)
    sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop                ' #5
    sl.Shapes(2).TextFrame.TextRange.Text = subtit(i)
    sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(6)    ' title only
    With sl.Shapes(1)
        .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
        .Top = 7
        .Left = 63
    End With
    With sl.Shapes(2)
        .Top = sl.Shapes(1).Top + sl.Shapes(1).Height - 30              ' position subtitle
        .Left = 608
        .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
        .TextFrame.TextRange.Font.Italic = msoTrue                      ' #2
        .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse          ' #3
        .Width = mypres.PageSetup.SlideWidth * 0.8                      ' #4
    End With
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set myShape = sl.Shapes(sl.Shapes.Count)
    With myShape
        .LockAspectRatio = 0
        .Left = la(i)
        .Top = ta(i)
        .Width = wa(i) * mypres.PageSetup.SlideWidth                    ' set picture size
        .Height = ha(i) * mypres.PageSetup.SlideHeight
    End With
    Set sl = mypres.Slides.Add(mypres.Slides.Count + 1, ppLayoutTitle)  ' title and subtitle
Next
If mypres.Slides.Count > 3 Then mypres.Slides(mypres.Slides.Count).Delete
Set sl = mypres.Slides.Add(1, ppLayoutTitleOnly)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(1)        ' desired background
sl.Shapes(1).TextFrame.TextRange.Text = "Cover"
objppt.Visible = 1
objppt.Activate
Application.CutCopyMode = False ' clear clipboard
'mypres.SaveAs "c:\users\public\finaldeck.pptx"
End Sub

 

[onthegreen03]

Worf - Sorry for the late response. I did not receive my usual email indicating a reply to the post. I actually logged on because I thought maybe you abandoned me! Glad to see you did not and that you are still working on this issue for me! Many thanks as usual. Let me run that code now and I will report back. What file do you need? The blank PP template or the one after I run the macro? I'd be happy to send you either one ... I can just remove any confidential data if needed. Again, let me know what file(s) you want and I can send them to you. How would I email you? In the meantime let me run that code now and I'll report back so you have that. THANKS!!!

 

[onthegreen03]

Okay I ran the code from 57 ... here you go

Layout 1
"Title Slide" Shapes = Title 1
"Title Slide" Shapes = Subtitle 2

Layout 2
"Title and Text" Shapes = Title 1
"Title and Text" Shapes = Text Placeholder 2
"Title and Text" Shapes = Slide Number Placeholder 3

Layout 6
"Title, Chart and Text" Shapes = Title 1
"Title, Chart and Text" Shapes = Chart Placeholder 2
"Title, Chart and Text" Shapes = Text Placeholder 3
"Title, Chart and Text" Shapes = Slide Number Placeholder 4

Layout 7
"Title and Diagram or Organization Chart" Shapes = Title 1
"Title and Diagram or Organization Chart" Shapes = SmartArt Placeholder 2
"Title and Diagram or Organization Chart" Shapes = Slide Number Placeholder 3

By the way I just ran the new code from 58 and I'm still getting the issue. The cover slide added (awesome) and slides 3-7 look great. That first data slide (now slide 2) is still an issue. The title comes in fine but the subtitle box just has a "2" in it.

Waiting for your reply.