Sub Export_nach_PowerPoint()
 
Dim Grafik As Shape
Dim powerpoint As powerpoint.Application
Dim powerpoint_Datei As powerpoint.Presentation
Dim powerpoint_Folie As powerpoint.Slide
 
On Error GoTo Error
 
Set powerpoint = CreateObject("powerpoint.Application")
With powerpoint
  .Visible = True
  .Presentations.Add
End With
 
Set powerpoint_Datei = powerpoint.ActivePresentation
 
For Each Grafik In ActiveSheet.Shapes
 'neue Folie einfügen
  powerpoint.ActivePresentation.Slides.Add 1, ppLayoutBlank
  Set powerpoint_Folie = powerpoint_Datei.Slides(1)
 'kopieren
  Grafik.CopyPicture
 'einfügen
  powerpoint_Folie.Shapes.Paste
Next
 
Set powerpoint_Folie = Nothing
Set powerpoint_Datei = Nothing
Set powerpoint = Nothing
 
Exit Sub
 
Error:
Set powerpoint_Folie = Nothing
Set powerpoint_Datei = Nothing
Set powerpoint = Nothing
    MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
    & "Beschreibung: " & Err.Description _
    , vbCritical, "Fehler"
End Sub