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]

Hi

I tested your workbook at work with Excel 2013 and got various error messages and program crashes.
Now I am home and tested it with Office 2007 for a change; got inconsistent errors but also some successful executions. In short, your file/data cannot be trusted; it may be corrupted in some way.
My proposal is that you perform the following test: create a brand new workbook from scratch, with little or no data, paste the code there and see if a PowerPoint presentation is correctly created. Run it several times.
If all goes well, there is something wrong with your current workbook and/or data.
Tell me what happens.

 

[onthegreen03]

Okay. I will set up a new file on Monday and report the results. What's weird is the code prior to the title tab being added seemed to work fine. I would get an occasional hiccup but for the most part it worked. Hopefully we can get this code working. You've spent so much time on it and that is much appreciated by me! Will contact you on Monday.

 

[onthegreen03]

Hi Worf - I did as you suggested and created a brand new Excel WB and pasted in the current code. Initially I was getting a run time error message (Shapes.PasteSpecial: Invalid Request. The specified data type is unavailable.) I'm not sure why it happened but eventually it stopped and I ran the code 5-6 times in a row without a problem. Maybe I forgot to close the generated PP deck? So after I ran the code I made sure to close the PP before running the code again, that is when I had the 100% success rate. All this being said it appears like my master file has some bad/corrupt data somewhere (as you predicted). What is the best way to rectify? Can I simply take this newly created file and copy the tabs from the other file? Or do I have to build everything from scratch? Starting from scratch would be tough as I spent weeks setting that file up, but you may tell me I have no choice. Let me know what you think. Thanks.

 

[Worf]

Hi

- I am glad things are looking brighter now.
- My suggestion now is that you copy the already existing sheets, one at a time, testing the code before adding the next one.
- Another idea to eliminate a potential problem: instead of running the macro via a shape, do it directly from the VBE.

 

[onthegreen03]

Hi - I added in the tabs from the old file and the new file seems to be working without errors. THANK YOU again for your time and efforts to get this project completed. I'll be in touch in a couple of days after I spend some time testing the new file. I want to give you what I hope will be the final update. Awesome job Worf!!

 

[onthegreen03]

Hi Worf - I did think of one thing as I was testing the code. Can you add code at the end which adds slide numbers to each slide? Right now after the code runs I manually go into "Insert/Slide Numbers" in PP and do it that way. If that is something that is easy to add without much work do you mind adding that? It would be a BIG help.

 

[onthegreen03]

Hi Worf - Just retagging this in case you did not get notification. I know its happened in the past with you and me as well. Thanks.

 

[Worf]

This version adds slide numbers:

Dim objppt As PowerPoint.Application, rng As Range, mypres As Presentation, sl As Object, _
shp As Object, sar, i%, rad, wa, ha, la, ta, tsl%, bl%


Sub RunAllMacros()
Procedure1
Procedure2
MsgBox "Success!", 64
End Sub


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


Sub Procedure2()
tsl = 1                                     ' title and subtitle layout
bl = 7                                      ' background layout for presentation body
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")
rad = Array("B7:T33", "B7:K33", "B3:P39", "B3:P39", "B3:P39", "B2:P36")
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(tsl)
For i = LBound(sar) To UBound(sar)
    FormatSlide (i + 1)
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set shp = sl.Shapes(sl.Shapes.Count)
    With shp
        .Name = "sheetrange"
        .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(tsl)          ' desired cover background
sl.Shapes(1).TextFrame.TextRange.Text = "Spiffy Medical"
sl.Shapes(2).TextFrame.TextRange.Text = "Third Quarter Results"
objppt.Visible = 1: objppt.Activate
Application.CutCopyMode = False
End Sub


Sub FormatSlide(sn)
Set sl = mypres.Slides(sn)
Do While sl.Shapes.Count > 2
    sl.Shapes(sl.Shapes.Count).Delete
Loop
sl.Shapes(1).Name = "_title"
sl.Shapes(2).Name = "sub_title"
sl.Shapes(1).TextFrame.TextRange.Text = Sheets("home").[a1].Offset(sn - 1)
sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop
sl.Shapes(2).TextFrame.TextRange.Text = Sheets("home").[b1].Offset(sn - 1)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(bl)
With sl.Shapes(1)
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
    .Top = 7
    .Left = 10
    .Width = mypres.PageSetup.SlideWidth * 0.98
    .TextFrame.TextRange.Font.Size = 22
    .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
    .TextFrame.TextRange.Font.Bold = 1
End With
With sl.Shapes(2)
    .Top = sl.Shapes(1).Top + sl.Shapes(1).Height - 30              ' position subtitle
    .Left = 10
    .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
    .TextFrame.TextRange.Font.Italic = msoTrue
    .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
    .Width = mypres.PageSetup.SlideWidth * 0.98
    .TextFrame.TextRange.Font.Size = 20
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
End With
sl.Shapes.AddShape msoShapeRectangle, 50, 50, 20, 15
With sl.Shapes(3)
    .Top = mypres.PageSetup.SlideHeight - 20
    .Left = mypres.PageSetup.SlideWidth - 20
    .TextFrame.TextRange.Text = sl.SlideIndex
End With
End Sub

 

[onthegreen03]

Worf - Thank you for working on this (again) and adding slide numbers. It did add slide numbers but I would like to ask for a couple of modifications in terms of placement and format.

1. Right now the macro is adding slide numbers to the lower right part of the slide .... can you change it to the lower left?

2. The slide number is coming in with a blue fill and white font color. Can you get rid of the fill and change the font color to black?

3. The text size is 18 .... can you lower it to 10 and italicize it?

4. Slide 2 has a slide number of 1 (I guess it doesn't account for the title page). Can you change the code so it starts adding numbers on slide 2 (with the slide number of 2)? I obviously do not want a slide number added to the title page but do want the numbering to start at 2 (slide 2).

If 2 and 3 prove to be too difficult let me know. I remember the last time I asked you to change the format of the subtitle box it created a lot of extra work for you. Also, I know you have a day job so I'll be patient and await your response even if it takes some time.

Thanks again !

 

[Worf]

you have a day job

Yes, that is a problem...

Dim objppt As PowerPoint.Application, rng As Range, mypres As Presentation, sl As Object, _
shp As Object, sar, i%, rad, wa, ha, la, ta, tsl%, bl%
Sub RunAllMacros()
Procedure1
Procedure2
MsgBox "Success!", 64
End Sub

Sub Procedure1()
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "d:\pub\blank.potx"       ' your path here
End Sub

Sub Procedure2()
tsl = 1                                     ' title and subtitle layout
bl = 7                                      ' background layout for presentation body
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")
rad = Array("B7:T33", "B7:K33", "B3:P39", "B3:P39", "B3:P39", "B2:P36")
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(tsl)
For i = LBound(sar) To UBound(sar)
    FormatSlide (i + 1)
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set shp = sl.Shapes(sl.Shapes.Count)
    With shp
        .Name = "sheetrange"
        .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(tsl)          ' desired cover background
sl.Shapes(1).TextFrame.TextRange.Text = "Spiffy Medical"
sl.Shapes(2).TextFrame.TextRange.Text = "Third Quarter Results"
sl.Shapes(3).Delete                                                         ' slide number
objppt.Visible = 1: objppt.Activate
Application.CutCopyMode = False
End Sub

Sub FormatSlide(sn)
Set sl = mypres.Slides(sn)
Do While sl.Shapes.Count > 2
    sl.Shapes(sl.Shapes.Count).Delete
Loop
sl.Shapes(1).Name = "_title"
sl.Shapes(2).Name = "sub_title"
sl.Shapes(1).TextFrame.TextRange.Text = Sheets("home").[a1].Offset(sn - 1)
sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop
sl.Shapes(2).TextFrame.TextRange.Text = Sheets("home").[b1].Offset(sn - 1)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(bl)
With sl.Shapes(1)
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
    .Top = 7
    .Left = 10
    .Width = mypres.PageSetup.SlideWidth * 0.98
    .TextFrame.TextRange.Font.Size = 22
    .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
    .TextFrame.TextRange.Font.Bold = 1
End With
With sl.Shapes(2)
    .Top = sl.Shapes(1).Top + sl.Shapes(1).Height - 30              ' position subtitle
    .Left = 10
    .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
    .TextFrame.TextRange.Font.Italic = msoTrue
    .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
    .Width = mypres.PageSetup.SlideWidth * 0.98
    .TextFrame.TextRange.Font.Size = 20
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
End With
sl.Shapes.AddShape msoShapeRectangle, 50, 50, 20, 15
With sl.Shapes(3)
    .Top = mypres.PageSetup.SlideHeight - 20
    .Left = 12
    .TextFrame.TextRange.Font.Color.RGB = RGB(1, 2, 3)
    .Fill.Visible = msoFalse
    .Line.ForeColor.RGB = RGB(250, 250, 250)
    .TextFrame.TextRange.InsertSlideNumber
    .TextFrame.TextRange.Font.Size = 10
    .TextFrame.TextRange.Font.Italic = msoTrue
End With
End Sub