Thema: Excel-Dias in Powerpoint per VBA | Herbers Excel-Forum

Hallo zusammen,
ich verfolge schon seit einigen Wochen verschiedenste Threads im Internet zum oben genannten Thema, da ich genau einen solchen Link herstellen will.
Leider kenn ich mich mit dem Thema Makros noch nicht so gut aus, und hab daher verschiedenste Schnippsel zusammenkopiert, geändert, probiert, geändert, gesucht, probiert etc.
Nun komm ich aber leider nicht weiter. Hier mein Problem, in der Hoffnung dass mir jemand helfen kann:
Ich habe eine Exceldatei mit mehreren Worksheets. Eins davon ist ein Übersichtsblatt auf dem sich Graphiken und Schaltflächen befinden, die Schaltflächen blenden per Makro andere Worksheets ein und aus, die bearbeitet werden können und die Graphiken auf der Übersicht aktualisieren.
Jetzt möchte ich meine Graphiken aus der Übersicht nach Powerpoint haben und zwar eine Graphik pro Folie.
Auf meiner Übersicht befinden sich Graphiken in Form von Zellen (z.B. A1:F15) oder auch Diagramme, die ich dort abgelegt habe.
Die erste Form kann inzwischen per VBA nach Powerpoint transferieren. Nur bei den eingebetteten Diagrammen hapert es derzeit. Momentan habe ich drei eingebettete Diagramme auf dem Übersichtsblatt und mein aktueller Makro kopiert diese auch nach Powerpoint auf Folie 4, nur dass er für jede Graphik eine PPT öffnet, statt alle Graphiken in EINER PPT hintereinander auf Folien zu packen.
Und hier hänge ich derzeit fest.
Ich poste mal den VBA Code:

Sub ChartObjectsNachPowerpoint()
' Kopiere Diagramm Beinnaheunfälle in Powerpoint
Dim pptApp As Object
Dim pptPres As Object
Dim chtObj As Object
Dim shp As Object
'Dateiname
PPPres = "D:\Test.ppt"
'Object referenzieren
Set PPApp = CreateObject("Powerpoint.Application")
For Each chtObj In ActiveSheet.ChartObjects
chtObj.Chart.ChartArea.Copy
'Object initialisieren
PPApp.Visible = msoTrue
'PPT öffnen
Set ppFile = PPApp.Presentations.Open(PPPres)
'Foliennummer angeben
PPApp.ActivePresentation.Slides(4).Select
'Bereich einfügen und OLE Verknüpfung herstellen = Link
With PPApp.ActiveWindow
.ViewType = ppViewSlide
.View.PasteSpecial DataType:=ppPasteDefault, link:=msoTrue
End With
'Eingefügte Tabelle skalieren
With PPApp.ActiveWindow.Selection.ShapeRange
'Oberer Rand 1 cm unter Standardtitel
.Top = 120
'Linker Rand 1.5 cm von linkem Folienrand
.Left = 180
'Eingefügte Tabelle auf Links und rechts 1,5 cm Rand skalieren
.Width = 650
'Bei Bedarf Höhe noch einstellen
'Hier ist jedoch zu beachten, dass das Object skaliert wird !!!
'Die Breite verändert sich dann
.Height = 300
End With
Next
pptApp.Visible = True
End Sub

Soweit. Achja, und bei

pptApp.Visible = True 

hängt er sich auch auf!
Ich hatte es auch probiert, statt eingebetteter Diagramme, diese als Worksheet abzulegen, aber auch das hab ich bisher nicht hingekriegt.
Weiß jemand Rat?

Hallo Kruemelcookie,
MS Powerpoint ist von Excel aus nicht so einfach zu handhaben.
Ich hab deine Prozedur mal ein wenig bezüglich Reihenfolge der Aktionen bereinigt und die Objektwelt aufbereitet.
In meinem Beispiel werden 3 Chart-Objekte an PP übergeben, hier muss du die Zählung der Slide ind die Chart-Objekte eingefügt werden entsprechend anpassen. in der PPDatei müssen schon entsprechend viele Leerfolien vorhanden sein, sonst crashed das Makro.
Bei läuft das Makro sehr langsam an, bis endlich die PowerPoint-Anwendung gestarte ist.
Gruß
Franz

Sub ChartObjectsNachPowerpoint()
' Kopiere Diagramm Beinnaheunfälle in Powerpoint
'Im Excel VBA-Editor für die Datei den Verweis auf die _
Microsoft Powerpoint object Library aktivieren
Dim pptApp As PowerPoint.Application
Dim ppFile As PowerPoint.Presentation, PPPres As String
Dim chtObj As Excel.ChartObject
Dim pptShape As PowerPoint.Shape
Dim pptSlide As PowerPoint.Slide
Dim intFolieNr As Long, arrFoliennummer, strPP_Neu As Variant
'Dateiname
PPPres = "D:\Test.ppt"
PPPres = "C:\Lokale daten\Test\Test01.ppt"
'Object referenzieren
Set pptApp = CreateObject("Powerpoint.Application")
pptApp.Visible = msoTrue
'PPT schreibgeschützt öffnen
Set ppFile = pptApp.Presentations.Open(PPPres, msoTrue)
'Liste und Reihenfolge der Slide-Nummern in die Grafiken eingefügt werden sollen
arrFoliennummer = Array(4, 5, 6)
intFolieNr = LBound(arrFoliennummer) - 1
'Ansicht in PP so einstellen, das Objekte in PP eingefügt werden können
With pptApp.ActiveWindow
.ViewType = ppViewSlide
End With
'3 Diagramm-Objekte vom aktiven Blatt in PP-Präsentation einfügen
For Each chtObj In ActiveSheet.ChartObjects
chtObj.Chart.ChartArea.Copy
'Object initialisieren
'Foliennummer angeben
intFolieNr = intFolieNr + 1
Set pptSlide = ppFile.Slides(arrFoliennummer(intFolieNr))
pptSlide.Select
'Bereich einfügen und OLE Verknüpfung herstellen = Link
With pptApp.ActiveWindow
.View.PasteSpecial DataType:=ppPasteDefault, link:=msoTrue
End With
Set pptShape = pptSlide.Shapes(pptSlide.Shapes.Count)
'Eingefügtes Objekt skalieren
With pptShape
'Oberer Rand 1 cm unter Standardtitel
.Top = 120
'Linker Rand 1.5 cm von linkem Folienrand
.Left = 180
'Eingefügte Tabelle auf Links und rechts 1,5 cm Rand skalieren
.Width = 650
'Bei Bedarf Höhe noch einstellen
'Hier ist jedoch zu beachten, dass das Object skaliert wird !!!
'Die Breite verändert sich dann
.Height = 300
End With
Next
pptApp.Visible = True
'Excel anzeigen für Dialog-Speichern-Name
Application.Visible = True
strPP_Neu = Application.GetSaveAsFilename(InitialFileName:=ppFile.Path & Application. _
PathSeparator _
& "TestPP01.ppt", Filefilter:="Powerpoint (*.ppt),*.ppt", _
Title:="Bitte Namen für neue PowerPoint Datei wählen/eingeben")
If strPP_Neu <> False Then
ppFile.SaveAs Filename:=strPP_Neu
ppFile.Close
pptApp.Quit
End If
'Objektvariablen aufräumen
Set chtObj = Nothing
Set pptSlide = Nothing
Set ppFile = Nothing
Set pptApp = Nothing
End Sub

Hi Franz,
super, vielen Dank, funktioniert wunderbar!
Allerdings eine Sache: irgendwie gefällt mir der Schreibschutz in ppt nicht so wirklich. Wie kann ich den denn im Makro rausnehmen?!
Alles was ich probiert habe, bringt mich immer wieder nur zum Debugger :O)
Danke!

Hallo Kruemelcookie,
in folgender Zeile den Prameter msoTrue weglassen oder auf msoFalse ändern

    Set ppFile = pptApp.Presentations.Open(PPPres, msoTrue)

Gruß
Franz