VBA Help- Copying multiple Excel Charts into Powerpoint

[mreljic]

Hello,

Every month I have to manually copy charts from Excel and paste them into Power Point. It is a manual process and I would like to improve it by adding a VBA code. Problem 1: The code below allows me to copy one Excel chart into Power Point each time. I have 3 charts on one tab and i want to copy and paste all 3 at the same time to PPT. Now, i have to select one chart and run the code below. Then select another chart on the same tab and run the code and so on.
Problem 2: When i run the VBA code below, i get an extra blank sheet in my power point presentation and i would like to remove that part of the code.

Please let me know if you need my excel file and ppt file. This is my first post and i dont see an option for uploading files.
Thank you,
Miro
Sub ChartToPresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim AddSlidesToEnd As Boolean
AddSlidesToEnd = False
' Make sure a chart is selected
If ActiveChart Is Nothing Then
MsgBox "Please select a chart and try again.", vbExclamation, _
"No Chart Selected"
Else
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
' Reference active slide
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
' Copy chart
ActiveChart.ChartArea.Copy
' Paste chart
PPSlide.Shapes.Paste.Select
' Position pasted chart
' This is the keypoint
' I want to replace this with the selection of appropriate layout
' and placeholder in that layout
PPApp.ActiveWindow.Selection.ShapeRange.Left = 29.52
PPApp.ActiveWindow.Selection.ShapeRange.Top = 79.2
PPApp.ActiveWindow.Selection.ShapeRange.Width = 216
PPApp.ActiveWindow.Selection.ShapeRange.Height = 121.68

If PPApp.ActivePresentation.Slides.Count = 0 Then
' Other key point
' can I add a specific layout, for example one named Two Content Layout + takeout
Set PPSlide = PPApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
Else
If AddSlidesToEnd Then
'Appends slides to end of presentation and makes last slide active
PPApp.ActivePresentation.Slides.Add PPApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank
PPApp.ActiveWindow.View.GotoSlide PPApp.ActivePresentation.Slides.Count
Set PPSlide = PPApp.ActivePresentation.Slides(PPApp.ActivePresentation.Slides.Count)
Else
'Sets current slide to active slide
Set PPSlide = PPApp.ActiveWindow.View.Slide
End If
End If

'Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing

End If
End Sub

 

[Worf]

Hello and welcome to the Board

It’s always better to work with the real thing, so you could upload the files to a file sharing site like Drop Box and paste the link here.
In the meantime, I’ll start working on the problem.

 

[mreljic]

Hi Worf,
thank you for your msg. https://www.dropbox.com/s/oifr18xl94n5cza/July 28, 2015 TEST123 Management Data Tables.zip?dl=0
I have modified the code a bit.
Step1: Please open the spreadsheet and powerpoint at the same time. You should be on the 2nd page in the PPT.
Step 2. Please go to the spreadsheet. If you select the tab Work Completion Charts, and then select all 3 charts, copy them and click on the "Export to PPT" button. The charts should be exported into PPT, Page two. The problem i am having now is how to resize the charts so they look like the same 3 charts in power point. Hint: When i was manually copying charts from Excel to PPT i would use paste special - picture enhanced metafile. Then i would manually resize the charts by lowering percentages from 100% to 60% and put them into a slot in PPT.


Step 3. On the tab PM IM & Asset tab similar logic is applied. Click on the horizontal bar chart and copy it , then press the PMIP button. The horizontal bar chart should be copied over to ppt. Problem: I want to position the new chart where the existing bar chart is in PPT. Again the dimension and location of the copied chart are the problem.

Again, thank you very much for your help. I have spent many hours looking at this macro. I am new to VBA.

Miro

 

[Jon Peltier]

1. Are there only four charts on the Excel worksheet? This will export all charts on the active Excel worksheet to the PowerPoint slide. You need to place it at the appropriate point of your code.

Dim chtob As ChartObject

For Each chtob In ActiveSheet.ChartObjects
    ' Copy chart
    chtob.Chart.ChartArea.Copy
    ' Paste chart
    PPSlide.Shapes.Paste.Select

    ' adjust pasted image position and size as needed
Next

2. This line is what adds the blank slide:

Set PPSlide = PPApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)

 

[Worf]

Hi Miro
- The following code seems to correctly position the three charts
- It still uses the manual method of select /copy the charts. Would you like the code to do it automatically?
- I will be back tomorrow with more.

Option Explicit
Option Base 1
Sub ChartToPresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application, PPPres As PowerPoint.Presentation, ar
Dim PPSlide As PowerPoint.Slide, AddSlidesToEnd As Boolean, ichart%, sh, sw
ar = Array(0.0237, 0.1895, 0.3587)
AddSlidesToEnd = False
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
' Reference active slide
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
PPSlide.Shapes.PasteSpecial.Select
sh = PPPres.PageSetup.SlideHeight
sw = PPPres.PageSetup.SlideWidth
With PPApp.ActiveWindow.Selection.ShapeRange
    .Top = sh * 0.1
    .Width = sw * 0.1765
    .Height = sh * 0.1515
End With
For ichart = 1 To PPApp.ActiveWindow.Selection.ShapeRange.Count
        PPApp.ActiveWindow.Selection.ShapeRange(ichart).Left = ar(ichart) * sw
Next
If PPPres.Slides.Count = 0 Then
    Set PPSlide = PPPres.Slides.Add(1, ppLayoutBlank)
Else
    If AddSlidesToEnd Then
         'Appends slides to end of presentation and makes last slide active
        PPPres.Slides.Add PPPres.Slides.Count + 1, ppLayoutBlank
        PPApp.ActiveWindow.View.GotoSlide PPPres.Slides.Count
        Set PPSlide = PPPres.Slides(PPPres.Slides.Count)
    Else
         'Sets current slide to active slide
        Set PPSlide = PPApp.ActiveWindow.View.Slide
    End If
End If
'Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub

 

[Jon Peltier]

@Worf -

Excel 2003 / windows xp (work)

Really? Wow. That can't be too common nowadays.

 

[Worf]

Hi Jon

- Yes, both Windows and Office officially unsupported by Microsoft. We have Windows 7/Office 2010 machines but I was not awarded one.
My work computer has a Pentium D processor with 1 GB RAM.
- The bright side is that with Excel 2003 charts I can drag a point with the mouse and the source cell changes accordingly…

 

[Worf]

Miro

Concerning the layout comment, here is an example:

' PowerPoint macro
Sub layouts()
Dim d As Design, cl As CustomLayout, i%
Set d = ActivePresentation.Designs(1)
For i = 1 To d.SlideMaster.CustomLayouts.Count
    MsgBox d.SlideMaster.CustomLayouts(i).Name, 64, "#" & i             ' show all
Next
ActivePresentation.Slides(4).CustomLayout = d.SlideMaster.CustomLayouts(4)  ' define layout
End Sub