Red face Excel charts as jpgs to specific powerpoint

sandra1990

New Member
Joined
Jan 22, 2018
Messages
3
Hi guys,


I am new and please forgive me, if am not specific enough.


I would like to export all of the charts using vba code in a horizontal order from a specific worksheet (sheet1) to a specific powerpoint which is already saved at the end of a given path.
The powerpoint file as well as the path where it is located are given in cells (please find the attached excel with charts, Cells W7 and W8).


Could you please help me with the code? I can provide you with the excel file.


Thank you in advance.
557482d1516651575-excel-charts-as-jpgs-to-specific-powerpoint-capture.jpg
 

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
Hi guys,

I went further, please find the code below.
HTML:
Sub ExcelToPowerPoint()


    Dim cht As ChartObject
    Dim cht2 As ChartObject
    Dim rng As Excel.Range
    Dim PowerPointApp As PowerPoint.Application
    Dim myPresentation As PowerPoint.Presentation
    Dim mySlide As PowerPoint.Slide
    Dim myShapeRange As PowerPoint.Shape
    Dim i As Long, j As Long
    
    'Create an Instance of PowerPoint
    On Error Resume Next
    'Is PowerPoint already opened?
    Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    
    'Clear the error between errors
    err.Clear

    'If PowerPoint is not already open then open PowerPoint
    If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
    If err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
    End If

    On Error GoTo 0
  
    'Open presentation listed in W7 and W8
    On Error GoTo err
    Set myPresentation = PowerPointApp.Presentations.Open(Range("w8") & "" & Range("w7"))
    
    'Make PowerPoint Visible and Active
    PowerPointApp.Visible = True
    PowerPointApp.Activate
    
    i = 0 'counter for chart
    j = 0 'counter for slide
    
    For Each cht In Worksheets("Nice").ChartObjects
        'Add a slide to the Presentation
        If i Mod 2 = 0 Then
            j = j + 1
        End If
        
        Set mySlide = myPresentation.Slides(j)
        
        'Copy Excel Range
        cht.Activate
        ActiveChart.ChartArea.Copy
        
        'Paste to PowerPoint
        mySlide.Shapes.PasteSpecial DataType:=ppPasteJPG
        Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
            With myShape
                .LockAspectRatio = True
                .Width = 200 'points wide
            End With
        'Set position:
        myShape.Left = 40 + ((i Mod 2) * 250)
        myShape.Top = 66
        i = i + 1
        
    Next cht
    
        For Each cht2 In Worksheets("Beautiful").ChartObjects
        'Add a slide to the Presentation
        If i Mod 2 = 0 Then
            j = j + 1
        End If
        
        Set mySlide = myPresentation.Slides(j)
        
        'Copy Excel Range
        cht2.Activate
        ActiveChart.ChartArea.Copy
        
        'Paste to PowerPoint
        mySlide.Shapes.PasteSpecial DataType:=ppPasteJPG
        Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
            With myShape
                .LockAspectRatio = True
                .Width = 200 'points wide
            End With
        'Set position:
        myShape.Left = 40 + ((i Mod 2) * 250)
        myShape.Top = 66
        i = i + 1
        
    Next cht2
    Exit Sub
    
err:
MsgBox "File name does not exist, please check and try again"

End Sub

Three issues are bothering me however.

1. I get "out of memory error"
2. I get the msg box "File name does not exist, please check and try again" although the job has been done appropriately (powerpoint opened, pictures pasted).
3. In the sheet "Nice" I prepared three charts in one line. Unfortunately only two are being pasted.

Could you please comment on that?
 
Upvote 0
The above problems are solved (please see the code below).

I am running into problems if there are not enough slides in the presentation.
Could only someone please tell me how to add the slides I have the code for it but dont know how and where to implement it, so that after pasting the three shapes another slide is going to be added and on this slide the subsequent shapes are going to be pasted.

Code:
ActivePresentation.Slides.Add Index:=ActivePresentation.Slides.Count + 1, Layout:=ppLayoutCustom


Code:
Sub ExcelToPowerPoint()

    Dim cht As ChartObject
    Dim cht2 As ChartObject
    Dim rng As Excel.Range
    Dim PowerPointApp As PowerPoint.Application
    Dim myPresentation As PowerPoint.Presentation
    Dim mySlide As PowerPoint.Slide
    Dim myShapeRange As PowerPoint.Shape
    Dim i As Long, j As Long
    
    'Create an Instance of PowerPoint
    On Error Resume Next
    'Is PowerPoint already opened?
    Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    
    'Clear the error between errors
    err.Clear


    'If PowerPoint is not already open then open PowerPoint
    If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
    If err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
    End If


    On Error GoTo 0
  
    'Open presentation listed in W7 and W8
    On Error GoTo err
    Set myPresentation = PowerPointApp.Presentations.Open(Range("w8") & "\" & Range("w7"))
    
    'Make PowerPoint Visible and Active
    PowerPointApp.Visible = True
    PowerPointApp.Activate
    
    i = 0 'counter for chart
    j = 0 'counter for slide
    
    For Each cht In Worksheets("Nice").ChartObjects
        'Add a slide to the Presentation
        If i Mod 3 = 0 Then
            j = j + 1
        End If
        
        Set mySlide = myPresentation.Slides(j)
        
        'Copy Excel Range
        cht.Activate
        ActiveChart.ChartArea.Copy
        
        'Paste to PowerPoint
        mySlide.Shapes.PasteSpecial DataType:=ppPasteJPG
        Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
            With myShape
                .LockAspectRatio = True
                .Width = 200 'points wide
            End With
        'Set position:
        myShape.Left = 30 + ((i Mod 3) * 200)
        myShape.Top = 66
        i = i + 1


        
    Next cht
    
            
        For Each cht2 In Worksheets("Beautiful").ChartObjects
        'Add a slide to the Presentation
        If i Mod 3 = 0 Then
            j = j + 1
        End If
        
        Set mySlide = myPresentation.Slides(j)
        
        'Copy Excel Range
        cht2.Activate
        ActiveChart.ChartArea.Copy
        
        'Paste to PowerPoint
        mySlide.Shapes.PasteSpecial DataType:=ppPasteJPG
        Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
            With myShape
                .LockAspectRatio = True
                .Width = 200 'points wide
            End With
        'Set position:
        myShape.Left = 30 + ((i Mod 3) * 200)
        myShape.Top = 66
        i = i + 1
        
    Next cht2


    Exit Sub
    
err:
MsgBox "File name does not exist, please check and try again"


End Sub
 
Upvote 0

Forum statistics

Threads
1,223,892
Messages
6,175,236
Members
452,621
Latest member
Laura_PinksBTHFT

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