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

O

onthegreen03

Board Regular
Joined
Jun 30, 2016
Messages
168
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
 
Sort by date Sort by votes

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Thanks Worf!

Okay, the code below works great for one range pasting into one slide in PP. I now want to expand it so that it copies one range from multiple tabs within the same Excel worksheet and pastes them into separate slides in the same PP deck. Can you help me build out the code so that it takes a range from 3 sheets (assume the sheet names as Sheet1, Sheet2, and Sheet3) and pastes them into the same PP deck? When done the PP deck will have 3 slides .... sometimes the code adds an extra slide which I prefer not to have. Assume the same range in all 3 sheets for now and the same sizing (if that is something you have to code separately). I thought once I have the basic coding down for 3 sheets I can easily add more sheets as needed.

I really appreciate your help on this "project". Believe it or not I've learned a lot and actually enjoy VBA .... wish I learned it earlier in life.

I will wait for your reply.

Thanks again!

' Excel module
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\Data Summary\E2P\Blank.potx"
End Sub

Sub Procedure2()

Dim rng As Range, mypres As PowerPoint.Presentation, mySlide As Object, myShape As Object

Set rng = ThisWorkbook.ActiveSheet.[B2:Q20]
Set mypres = objppt.ActivePresentation
Set mySlide = objppt.ActiveWindow.View.Slide

'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 = 8
myShape.Top = 100
myShape.Width = 700
myShape.Height = 400

'Make PowerPoint Visible and Active
objppt.Visible = 1
objppt.Activate

'Clear The Clipboard
Application.CutCopyMode = False
End Sub
 
Upvote 0
Please test this:

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 "d:\pub\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%
sar = Array("Sheet1", "Sheet2", "Sheet3")
Set mypres = objppt.ActivePresentation
Set mySlide = objppt.ActiveWindow.View.Slide
For i = LBound(sar) To UBound(sar)
    Set rng = ThisWorkbook.Sheets(sar(i)).[b2:q20]      ' ranges can be different if needed
    rng.Copy
    mySlide.Shapes.PasteSpecial DataType:=2             '2 = ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.Left = 8
    myShape.Top = 80
    myShape.Width = 300                                 ' sizes can be different if needed
    myShape.Height = 350
    Set mySlide = mypres.Slides.Add(mypres.Slides.Count + 1, 11)
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 "d:\pub\finaldeck.pptx"
End Sub
 
Upvote 0
Hi Worf - The macro ran as expected but for the 2nd and 3rd slide it is not resizing the picture to fit the slide. I'm assuming I can resize each picture as needed but where/how? Do you mind if I asked you to select 3 different ranges and 3 different sizes so I can see how you write the code? You don't know how much I appreciate the help on this!!! If you get sick of helping let me know and I'll stop bothering you. Also, if you want to take this off line I can send you my email if its easier. Thanks again! This is genius.
 
Upvote 0
If you get sick of helping let me know
Click to expand...

This is fun for me... ;)

if you want to take this off line
Click to expand...

Forum rule #4 forbids us to do that, see the link on my signature.

Code: 
' Excel module
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
sar = Array("Sheet1", "Sheet2", "Sheet3")
rad = Array("b2:q20", "d4:p18", "e6:n12")               ' ranges
wa = Array(0.9, 0.8, 0.75)                              ' percentages of slide width and height
ha = Array(0.85, 0.7, 0.65)
Set mypres = objppt.ActivePresentation
Set mySlide = objppt.ActiveWindow.View.Slide
For i = LBound(sar) To UBound(sar)
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    mySlide.Shapes.PasteSpecial DataType:=2             '2 = ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.Left = 8
    myShape.Top = 80
    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, 11)
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
 
Upvote 0
Hi Worf - I pasted in the new code and the different ranges are working and I now understand how to add sheets with different ranges (thanks!!!). Still having a problem with sizing the ranges into the slides. For all 3 ranges the width is too long ... the picture hangs off the right side of the slide by a lot. I tried to change the percentages under the "wa" line of code (lowered to 40%) but it didn't seem to change the width at all. Maybe I am not changing the right code? Do you mind taking another look at it? Do you see the same thing when you run it on your end? As always I appreciate your willingness to help. And to avoid breaking board rules I will keep replying through this thread ... I am a relative newbie to the site. After we (you) fix this I have one more very small favor to ask ... you'll be able to fix it in about 2 mins. I'll wait to hear from you. Thanks again.
 
Upvote 0
Does this fix it?

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:\pub\template2.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
sar = Array("Sheet1", "Sheet2", "Sheet3")
rad = Array("b2:q20", "d4:p18", "e6:n12")               ' ranges
wa = Array(0.25, 0.3, 0.45)                              ' percentages of slide width and height
ha = Array(0.85, 0.7, 0.65)
Set mypres = objppt.ActivePresentation
Set mySlide = objppt.ActiveWindow.View.Slide
For i = LBound(sar) To UBound(sar)
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
[COLOR=#ff8c00]    myShape.LockAspectRatio = 0[/COLOR]
    myShape.Left = 8
    myShape.Top = 80
    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, 11)
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:\pub\finaldeck.pptx"
End Sub
 
Upvote 0
Hi Worf - I had to change the wa settings but it is working and resizing as needed. The last request with this code .... can you update the coding so it does not add an empty slide at the end? Currently it leaves an empty (blank) slide. I love that you added the save file feature .... very nice! After this I have one more favor to ask regarding another VBA code I've been tinkering around with. Thanks!!!!
 
Upvote 0
This one should produce a three slide presentation:

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:\pub\template2.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
sar = Array("Sheet1", "Sheet2", "Sheet3")
rad = Array("b2:q20", "c4:p18", "e6:n12")               ' ranges
wa = Array(0.25, 0.3, 0.45)                              ' percentages of slide width and height
ha = Array(0.85, 0.7, 0.65)
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)
    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 = 8
    myShape.Top = 80
    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, 11)
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:\pub\finaldeck.pptx"
End Sub
 
Upvote 0
Thanks Worf! It worked like a charm and I really appreciate the help with that code. Last request (I hope). Below is another code I've pieced together from different sources to copy/paste charts from Excel to PP. The code works except that it leaves the first slide blank and adds slides from there. Like the last request I would like to have it start pasting from the active slide upon opening the deck and adding from there so that no blank slides exist after the code runs. As always thanks for the help!!!

Sub CreatePowerPoint()

'Add a reference to the Microsoft PowerPoint Library by:
'1. Go to Tools in the VBA menu
'2. Click on Reference
'3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay

'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject

'Look for existing instance
On Error Resume Next
Set newPowerPoint = CreateObject("PowerPoint.Application")
newPowerPoint.Visible = True
newPowerPoint.Presentations.Open "M:\Forecasting\Models\2016\Data Summary\E2P\Blank.potx"
On Error GoTo 0

'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each cht In ActiveSheet.ChartObjects

'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

'Copy the chart and paste it into the PowerPoint as a Metafile Picture
cht.Select
ActiveChart.ChartArea.Copy
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select

'Set the title of the slide the same as the title of the chart
activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text

'Adjust the positioning of the Chart on Powerpoint Slide
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125

activeSlide.Shapes(2).Width = 200
activeSlide.Shapes(2).Left = 505

'If the chart is the "Revlimid" consumption chart, then enter the appropriate comments
If InStr(activeSlide.Shapes(1).TextFrame.TextRange.Text, "Revlimid") Then
activeSlide.Shapes(2).TextFrame.TextRange.Text = Range("J7").Value & vbNewLine
activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J8").Value & vbNewLine)
activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J9").Value & vbNewLine)
activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J10").Value & vbNewLine)
'Else if the chart is the "Pomalyst" consumption chart, then enter the appropriate comments
ElseIf InStr(activeSlide.Shapes(1).TextFrame.TextRange.Text, "Pomalyst") Then
activeSlide.Shapes(2).TextFrame.TextRange.Text = Range("J27").Value & vbNewLine
activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J28").Value & vbNewLine)
activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J29").Value & vbNewLine)
activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J30").Value & vbNewLine)
End If

'Now let's change the font size of the callouts box
activeSlide.Shapes(2).TextFrame.TextRange.Font.Size = 16

Next

AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question Question
VBA code for PowerPoint works when I step through it, but breaks when run
Replies
2
Views
816
Green_Square_Window
G
M
  • Question Question
Data Transfer from Excel to PowerPoint and getting PDF file of PPT
Replies
1
Views
127
Sequoyah
Sequoyah
H
  • Question Question
Copy Tables & Charts from Excel to Powerpoint, Keep source formatting and change position
Replies
0
Views
385
h899
H
T
  • Question Question
VBA to update Powerpoint Text from Excel Data in Cells
Replies
9
Views
1K
tbakbradley
T
L
  • Locked
  • Question Question
How set range for chart in powerpoint created from vba
Replies
0
Views
121
Legacy 519704
L

Forum statistics

Threads
1,224,829
Messages
6,181,218
Members
453,024
Latest member
Wingit77

Share this page

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