Embed workshet into powerpoint using vba excel 2013

[Jessica.Bush]

Hi all,

I hope someone can help me please.

I have charts in excel and I would like to export them into a powerpoint slide using VBA. I can do this fine as a picture.
However I would like to have the ability to format it within powerpoint and also to change the data BUT not have it linked to the source data.

Essentially have the same ability to do everything I can if I opened ppt and did 'insert chart' but copying and pasting it from the pre-existing chart in my excel workbook.

I hope this makes sense?

To put this need in context:

• I have excel workbooks with standard charts in them.

• If someone wants to replicate this in ppt they current insert chart, format again and copy and paste the data - totally inefficient.

• However having it link to the source data wouldn't work as someone on a train / aeroplane may need to edit the data / format and they wouldn't have access to the source data. Plus having the link is too risky as people may not understand the full consequences of what they are changing.

Thanks for your help in advance.

[AlphaFrog]

Can you show your code? At least the part that copies the chart and pastes it as a picture in PP.

[Jessica.Bush]

Sub ExcelRangeToPowerPoint()

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 ', ActFileName As String

Application.ScreenUpdating = False

'Copy Range from Excel
  Set Rng = Selection

    Set PowerPointApp = CreateObject("Powerpoint.Application")
    
    'If powerpoint already open, select active presentation. If not offer to open pre-existing saved presentation. If cancelled, open company standard presentation template.
    If PowerPointApp.Presentations.Count = 0 Then
    
        ActFileName = Application.GetOpenFilename("Microsoft PowerPoint-Files (*.ppt*), *.ppt*")
        
        If ActFileName <> False Then
            Set PowerPointApp = CreateObject("Powerpoint.Application")
            
            PowerPointApp.Presentations.Open ActFileName
            Set myPresentation = PowerPointApp.ActivePresentation
        Else
            Set PowerPointApp = CreateObject("Powerpoint.Application")
            PowerPointApp.Presentations.Open "filepath"
'            PowerPointApp.Activate
'            PowerPointApp.Presentations.Add
            Set myPresentation = PowerPointApp.ActivePresentation
        End If
        
        Else
        With GetObject(, "PowerPoint.Application")
            Set myPresentation = .ActivePresentation
          End With
    '        Set myPresentation = PowerPointApp.Presentations
        End If
     
'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate
    
    
    SlidesCount = myPresentation.Slides.Count() + 1
''Add a slide to the Presentation
  Set mySlide = myPresentation.Slides.Add(SlidesCount, ppLayoutTitleOnly)
    
'Copy Excel Range
  Rng.Copy

'Paste to PowerPoint 
  mySlide.Shapes.pastespecial DataType:=ppPasteEnhancedMetafile
  Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
  
    myShapeRange.ScaleHeight 1, msoTrue
    myShapeRange.ScaleWidth 1, msoTrue
  
'Set position and size:
    With myPresentation.PageSetup
      myShapeRange.Width = .SlideWidth * 0.6
      myShapeRange.Height = .SlideHeight * 0.6
      myShapeRange.Left = (.SlideWidth \ 2) - (myShapeRange.Width \ 2)
      myShapeRange.Top = (.SlideHeight \ 2) - (myShapeRange.Height \ 2) + 50
    End With

'Clear The Clipboard
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

Thanks!

[AlphaFrog]

I'm not sure how you want to select the charts. This uses the ActiveChart in Excel. So select a chart before running the procedure.

Sub ExcelRangeToPowerPoint()

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 ', ActFileName As String
Dim cht As Chart

Application.ScreenUpdating = False

'Copy Range from Excel
  'Set Rng = Selection
  Set cht = ActiveChart

    Set PowerPointApp = CreateObject("Powerpoint.Application")
    
    'If powerpoint already open, select active presentation. If not offer to open pre-existing saved presentation. If cancelled, open company standard presentation template.
    If PowerPointApp.Presentations.Count = 0 Then
    
        ActFileName = Application.GetOpenFilename("Microsoft PowerPoint-Files (*.ppt*), *.ppt*")
        
        If ActFileName <> False Then
            Set PowerPointApp = CreateObject("Powerpoint.Application")
            
            PowerPointApp.Presentations.Open ActFileName
            Set myPresentation = PowerPointApp.ActivePresentation
        Else
            Set PowerPointApp = CreateObject("Powerpoint.Application")
            PowerPointApp.Presentations.Open "filepath"
'            PowerPointApp.Activate
'            PowerPointApp.Presentations.Add
            Set myPresentation = PowerPointApp.ActivePresentation
        End If
        
        Else
        With GetObject(, "PowerPoint.Application")
            Set myPresentation = .ActivePresentation
          End With
    '        Set myPresentation = PowerPointApp.Presentations
        End If
     
'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate
    
    
    SlidesCount = myPresentation.Slides.Count() + 1
''Add a slide to the Presentation
  Set mySlide = myPresentation.Slides.Add(SlidesCount, ppLayoutTitleOnly)
    
'Copy Excel Range
  'Rng.Copy
  cht.ChartArea.Copy

'Paste to PowerPoint
  'mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
  mySlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoFalse
  Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
  
    myShapeRange.ScaleHeight 1, msoTrue
    myShapeRange.ScaleWidth 1, msoTrue
  
'Set position and size:
    With myPresentation.PageSetup
      myShapeRange.Width = .SlideWidth * 0.6
      myShapeRange.Height = .SlideHeight * 0.6
      myShapeRange.Left = (.SlideWidth \ 2) - (myShapeRange.Width \ 2)
      myShapeRange.Top = (.SlideHeight \ 2) - (myShapeRange.Height \ 2) + 50
    End With

'Clear The Clipboard
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

[Jessica.Bush]

This works perfectly, thank you for your help! It seems so simple now...

[AlphaFrog]

You're welcome. Thanks for the feedback.