Excel charts to Powerpoint exporting using VBA

Hi,
please try the sample code below:

Public Sub ChartsToPpt()
  Dim sht As Object
  Dim cht As Excel.ChartObject
  Dim appPpt As Object 'PowerPoint.Application
  Dim prs As Object 'PowerPoint.Presentation
 
  'Create New Presentation
  Set appPpt = CreateObject("PowerPoint.Application")
  appPpt.Visible = msoTrue
  Set prs = appPpt.Presentations.Add(msoTrue)
 
  For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      sht.Select
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            cht.Select
            Application.CommandBars.ExecuteMso "Copy"
            PasteChart appPpt, prs
          Next
        Case "chart"
          Application.CommandBars.ExecuteMso "Copy"
          PasteChart appPpt, prs
      End Select
    End If
  Next
End Sub

Private Sub PasteChart(ByVal PowerPointApplication As Object, _
                       ByVal TargetPresentation As Object)
  Dim sld As Object 'PowerPoint.Slide
  Dim cnt As Long
  Const ppLayoutBlank = 12
 
  Set sld = TargetPresentation.Slides.Add( _
    TargetPresentation.Slides.Count + 1, ppLayoutBlank) 'Add New Slide
  sld.Select
  cnt = sld.Shapes.Count
 
  PowerPointApplication.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting"
  Do
   DoEvents
  Loop Until cnt <> sld.Shapes.Count
End Sub

-------------

Public Sub ChartsToPptAsImage()
  Dim sht As Object
  Dim cht As Excel.ChartObject
  Dim appPpt As Object 'PowerPoint.Application
  Dim prs As Object 'PowerPoint.Presentation
 
  'Create New Presentation
  Set appPpt = CreateObject("PowerPoint.Application")
  appPpt.Visible = msoTrue
  Set prs = appPpt.Presentations.Add(msoTrue)
 
  For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            cht.CopyPicture Appearance:=xlScreen, _
                            Format:=xlBitmap
            PasteChartImage prs
          Next
        Case "chart"
          sht.ChartArea.Copy
          PasteChartImage prs
      End Select
    End If
  Next
End Sub

Private Sub PasteChartImage(ByVal TargetPresentation As Object)
  Dim sld As Object 'PowerPoint.Slide
  Const ppLayoutBlank = 12
  Const ppPasteBitmap = 1
 
  Set sld = TargetPresentation.Slides.Add( _
    TargetPresentation.Slides.Count + 1, ppLayoutBlank) 'Add New Slide
  With sld.Shapes.PasteSpecial(DataType:=ppPasteBitmap, Link:=msoFalse)
    .Align msoAlignCenters, True
    .Align msoAlignMiddles, True
  End With
End Sub

hope this helps.
kinuasa