Diagramme in eine neue Powerpoint Datei kopieren
02.02.2018 12:53:34
Dominik
ich habe eine Frage zum Export per VBA von Diagrammen in eine Powerpoint Datei.
Ich habe ein Sheet mit diversen Diagrammen (einige ausgeblendet, einige nicht, situationsabhängig).
Die sichtbaren Diagramme möchte ich per Klick in eine Powerpoint Datei exportieren, jedes Diagramm auf eine neue Folie (am liebsten jeweils zentriert).
Im Optimalfall wird Powerpoint dann automatisch geschlossen und die erstellte Datei erhält den Namen der Excel-Datei, nur mit der Endung pptx.
Meine Versuche sind bisher absolut fehlgeschlagen (habe ergoogelte Makros probiert), jedoch gelingt es mir nicht, dass nur die sichtbaren Diagramme kopiert werden. Unten der Code, welchen ich gefunden habe, dieser kopiert aber jede enthaltene Grafik, das ist nicht gewünscht. Auch das automatische Speichern und die Namensvergabe sind nicht enthalten.
Benötigt ihr eine Beispieldatei? Im Grunde enthält diese jedoch nur X Diagramme, einige davon ausgeblendet.
Ich hoffe, ihr könnt mir weiterhelfen.
Viele Grüße,
Dominik
Sub jede_Grafik_nach_PowerPoint()
'Extras - Verweise: Microsoft PowerPoint x.x Object Library
Dim Grafik As Shape
Dim PP As PowerPoint.Application
Dim PP_Datei As PowerPoint.Presentation
Dim PP_Folie As PowerPoint.Slide
On Error GoTo Hell
Set PP = CreateObject("Powerpoint.Application")
With PP
.Visible = True
.Presentations.Add
End With
Set PP_Datei = PP.ActivePresentation
For Each Grafik In ActiveSheet.Shapes
'neue Folie einfügen
PP.ActivePresentation.Slides.Add 1, ppLayoutBlank
Set PP_Folie = PP_Datei.Slides(1)
'kopieren
Grafik.CopyPicture
'einfügen
PP_Folie.Shapes.Paste
'Grafik ausrichten
With PP_Folie.Shapes(1)
.IncrementLeft 340
.IncrementTop 180
End With
Next
Set PP_Folie = Nothing
Set PP_Datei = Nothing
Set PP = Nothing
Exit Sub
Hell:
Set PP_Folie = Nothing
Set PP_Datei = Nothing
Set PP = Nothing
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
End Sub