VBA: Copy plots from excel to PowerPoint

[grubarbarian]

Dear Wizards,

I have the following script that works great for going through a multi-worksheet excel file and copying and pasting the plots onto a new slide in PowerPoint. My problem is that some worksheets have 2 or more charts on them and I would like to develop the code below so that when there are more than one chart per worksheet that these charts to be displayed on one single PowerPoint slide (ie) 2 or more charts per single slide, whilst maintaining the feature that the other worksheets that have only 1 chart are still plotted on a singe slide.

Many thanks in advance,

Sub ExportChartsToPowerPoint_SingleWorkbook()
'declare PowerPoint Variables
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim SldIndex As Integer


'declare an Excel Object Variables
Dim Chrt As ChartObject
Dim WrkSht As Worksheet

'Create a new instance of PowerPoint
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True

'Create a new Presentation within the application
Set PPTPres = PPTApp.Presentations.Add

'CREATE AN INDEX HANDLER FOR SLIDE CREATION
SldIndex = 1

'Loop through all of the worksheet in the ACTIVE workbook
For Each WrkSht In Worksheets

'Loop through all the chart objects on the ACTIVE sheet
For Each Chrt In WrkSht.ChartObjects

'Copy the chart
Chrt.Copy

'Create a new slide, set the layout to blank, and paste the chart on the slide
Set PPTSlide = PPTPres.Slides.Add(SldIndex, ppLayoutBlank)
PPTSlide.Shapes.Paste

'Increment our slide index
SldIndex = SldIndex + 1

Next Chrt

Next WrkSht


End Sub

 

[Domenic]

In future, please post your code within code tags so that it's easier to read. Having said that, I have amended your code as follows. Note that you'll need to make changes to suit your needs. In particular, you'll need to change the starting left and top positions for each slide, along with the desired gap between charts.

Sub ExportChartsToPowerPoint_SingleWorkbook()

 
    'declare constants for the starting left and top positions for each slide,
    'along with the gap between charts (change as desired)
    Const StartLeftPos As Single = 50
    Const StartTopPos As Single = 50
    Const Gap As Long = 30

    'declare PowerPoint Variables
    Dim PPTApp As PowerPoint.Application
    Dim PPTPres As PowerPoint.Presentation
    Dim PPTSlide As PowerPoint.Slide
    Dim PPTShape As PowerPoint.Shape
    Dim SldIndex As Integer


    'declare an Excel Object Variables
    Dim Chrt As ChartObject
    Dim WrkSht As Worksheet
    Dim ChrtIndex As Long
    Dim CurrentLeftPos As Single
    Dim CurrentTopPos As Single

    'Create a new instance of PowerPoint
    Set PPTApp = New PowerPoint.Application
    PPTApp.Visible = True

    'Create a new Presentation within the application
    Set PPTPres = PPTApp.Presentations.Add

    'CREATE AN INDEX HANDLER FOR SLIDE CREATION
    SldIndex = 1

    'Loop through all of the worksheet in the ACTIVE workbook
    For Each WrkSht In Worksheets

        'Create a new slide, set the layout to blank
        Set PPTSlide = PPTPres.Slides.Add(SldIndex, ppLayoutBlank)
    
        'Index handler for chart
        ChrtIndex = 1
    
        'Starting left position for slide
        CurrentLeftPos = StartLeftPos
    
        'Starting top position for slide
        CurrentTopPos = StartTopPos
    
        'Loop through all the chart objects on the ACTIVE sheet
        For Each Chrt In WrkSht.ChartObjects
    
            'Copy the chart
            Chrt.Copy
        
            'Paste the chart on the slide
            Set PPTShape = PPTSlide.Shapes.Paste(1)

            'Position newly pasted chart on the slide
            If (ChrtIndex Mod 2) = 1 Then
                With PPTShape
                    .Left = CurrentLeftPos
                    .Top = CurrentTopPos
                    CurrentLeftPos = CurrentLeftPos + .Width + Gap
                End With
            Else
                With PPTShape
                    .Left = CurrentLeftPos
                    .Top = CurrentTopPos
                    CurrentLeftPos = StartLeftPos
                    CurrentTopPos = CurrentTopPos + .Height + Gap
                End With
            End If
        
            ChrtIndex = ChrtIndex + 1
    
        Next Chrt

        'Increment our slide index
        SldIndex = SldIndex + 1
    
    Next WrkSht

End Sub

Hope this helps!

 

[grubarbarian]

Thank you so much. Please, if I can bother you one more time, can you show me how to :
1) paste the plots as pictures rather than "live" plots
2) show me how to change the format so that when there are two plots per slide that the plots are stacked on top of each other.

Many thanks!!

 

[Domenic]

You're very welcome, glad I could help. As per your request, I have amended the macro to copy charts as a picture, and to stack each one below the other...

Sub ExportChartsToPowerPoint_SingleWorkbook()

    'declare constants
    Const LeftPos As Single = 50
    Const TopPos As Single = 50
    Const Gap As Long = 30

    'declare PowerPoint Variables
    Dim PPTApp As PowerPoint.Application
    Dim PPTPres As PowerPoint.Presentation
    Dim PPTSlide As PowerPoint.Slide
    Dim PPTShape As PowerPoint.Shape
    Dim SldIndex As Integer
    
    
    'declare an Excel Object Variables
    Dim Chrt As ChartObject
    Dim WrkSht As Worksheet
    Dim CurrentTopPos As Single
    
    'Create a new instance of PowerPoint
    Set PPTApp = New PowerPoint.Application
    PPTApp.Visible = True
    
    'Create a new Presentation within the application
    Set PPTPres = PPTApp.Presentations.Add
    
    'CREATE AN INDEX HANDLER FOR SLIDE CREATION
    SldIndex = 1
    
    'Loop through all of the worksheet in the ACTIVE workbook
    For Each WrkSht In Worksheets
    
        'Create a new slide, set the layout to blank
        Set PPTSlide = PPTPres.Slides.Add(SldIndex, ppLayoutBlank)
        
        'Starting top position for slide
        CurrentTopPos = TopPos
        
        'Loop through all the chart objects on the ACTIVE sheet
        For Each Chrt In WrkSht.ChartObjects
        
            'Copy the chart
            Chrt.Chart.CopyPicture
            
            'Paste the chart on the slide
            Set PPTShape = PPTSlide.Shapes.Paste(1)

            'Position newly pasted chart on the slide
            With PPTShape
                .Left = LeftPos
                .Top = CurrentTopPos
                CurrentTopPos = CurrentTopPos + .Height + Gap
            End With
            
        Next Chrt
    
        'Increment our slide index
        SldIndex = SldIndex + 1
        
    Next WrkSht

End Sub

 

[grubarbarian]

Tremendous!! Thank you so much. I'll mess around with your amazing code to try to re-size the plots, but you've done all of the hard part!

 

[Domenic]

You're very welcome, cheers!