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]

Worf - You did it!!! Awesome job! The resulting PP looks great now and no extra mag boxes. I'm not sure how you did it but a BIG thanks. What I'd like to do before I leave you alone is test it over the next few days with real data (15-20 slides). I may have some questions about positioning and sizing, formatting, etc. Once I have that master deck set I'll be off and running. I'll get in touch with you early next week to let you know where everything stands as it relates to the project. Thank you!!

 

[onthegreen03]

Worf - Quick question. Is there a way to link my title and subtitle text to cells in Excel instead of typing them out in VBA? The problem I am running into is some of my subtitles are really long and contain numbers. Those numbers change frequently which would require me to constantly update the subtitles in the code. I was hoping there was a way to link the array titles and subtitles to Excel cells (the same file that I am copying the pictures from). This way when the macro runs it grabs those updated titles/subtitles and uses them for the corresponding slides. Does this make sense? Is it possible?

 

[Worf]

Sorry for the delayed answer, I did not see your last post…
This code retrieves the strings from range A1:B6 of a sheet named home; titles in column A, subtitles in column B.

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") ' 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(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
'mypres.SaveAs "c:\users\public\finaldeck.pptx"
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
End Sub

 

[onthegreen03]

Thanks Worf! I'm glad you responded ... I thought maybe you saw my post and went running & screaming! Ha Ha. I'll try this out today and let you know how it works. I've been using the code now for a week and it works GREAT. Really the only issue I'd like to solve is being able to set up my titles and subtitles in an Excel sheet within that same file so the code pulls the text from there (as opposed to me changing the actual VBA code each time). Stay tuned!

 

[onthegreen03]

Hi Worf - I tried the new code and I am getting an Excel error message that reads: "Object library invalid or contains references to object definitions that could not be found". I noticed that my "RunAllMacros" had to have the new "FormatSlide (sn)" procedure added. So now that macro runs all 3 procedures. I also added the "Home" tab to the file so that is there. Any idea what happened? Let me know if sending you my files will make things easier.

 

[Worf]

- My code does not call the slide formatting routine in that procedure; I am not sure what you are doing…
- Yes, please post your current code or email me the files.
- What line throws the error?

 

[Worf]

Hi

(Email communication took place)
You will get the out of range error if that A1:B6 range is empty.
Please type something there and try again…

 

[onthegreen03]

Worf - I bow down to your Excel greatness. Very nice! As you predicted it worked once I added the text in those cells. Last question. If I end up having 10 slides do I just keep typing down? So the range would extend to A1:B10 but I will not have to change the code correct?

 

[Worf]

The code currently loops the elements of the sheet names array. Would you like to transfer all the arrays from the second procedure to a worksheet range?
This would eliminate value hardcoding in the VBA and the loop would be controlled by the range size.

 

[onthegreen03]

Worf - I think I am okay with leaving the code as is although I'm getting another (different) error when I try the new code in my master file. I will send you an email now with my master Excel file (a lot more tabs) so you can test on your end. The error code is a Compile Error which reads "Only comments may appear after End Sub, End Function, or End Property. The code stops at the line Sub FormatSlide (sn). Just so you are aware I did change the tab name with the titles from "Home" to "Titles". I also have 15 tabs which are now part of the array instead of 6 in the test file. Hopefully by checking over my master file instead of the test file we can finally wrap this up. Sending email now.