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

onthegreen03

Board Regular
Joined
Jun 30, 2016
Messages
148
Office Version
  1. 365
Platform
  1. Windows
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
 
inacreditável & obrigado!

Worf, you are a master of your craft. I can't thank you enough for your time and efforts. The macro is a work of art and works beautifully. I'll try to not contact you again but I hope you don't mind if I do should I need some help down the road. Thanks again.
 
Upvote 0

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Yes, that is a problem... :rolleyes:

Code:
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
Hey Worf. You likely will not remember be but you helped me back in 2016 with some Excel to PP coding, which turned out great by the way. I am trying to copy that old code into a new file but am having issues getting it to work. If you get this and have a few seconds let me know and I'll send you the exact issue. Thanks.
 
Upvote 0

Forum statistics

Threads
1,213,532
Messages
6,114,177
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top