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

Some videos you may like

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

onthegreen03

Board Regular
Joined
Jun 30, 2016
Messages
61
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
 

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
4,004
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
 

onthegreen03

Board Regular
Joined
Jun 30, 2016
Messages
61
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.
 

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
4,004
If you get sick of helping let me know
This is fun for me... ;)

if you want to take this off line
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
 

onthegreen03

Board Regular
Joined
Jun 30, 2016
Messages
61
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.
 

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
4,004
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
 

onthegreen03

Board Regular
Joined
Jun 30, 2016
Messages
61
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!!!!
 

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
4,004
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
 

onthegreen03

Board Regular
Joined
Jun 30, 2016
Messages
61
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
 

Watch MrExcel Video

Forum statistics

Threads
1,102,867
Messages
5,489,367
Members
407,686
Latest member
Chuck1960

This Week's Hot Topics

  • Timer in VBA - Stop, Start, Pause and Reset
    [CODE=vba][/CODE] Option Explicit Dim CmdStop As Boolean Dim Paused As Boolean Dim Start Dim TimerValue As Date Dim pausedTime As Date Sub...
  • how to updates multiple rows in muliselect listbox
    Hello everyone. I need help with below code. code is only chaning 1st row in mulitiselect list box. i know issue with code...
  • Delete Row from Table
    I am trying to delete a row from a table using VBA using a named range to find what I need to delete. My Range is finding the right cell. In the...
  • Assigning to a variable
    I have a for each block where I want to assign the value in column 5 of the found row to the variable Serv. [CODE=vba] For Each ws In...
  • Way to verify information
    Hi All, I don't know what to call this formula, and therefore can't search. I have a spreadsheet with information I want to reference...
  • Active Cell Address – Inactive Sheet
    How to use VBA to get the cell address of the active cell in an inactive worksheet and then place that cell address in a location on the current...
Top