Diagrammdaten aus PPT nach XLS kopiere
12.02.2021 16:14:01
Marco
vielleicht kann mir jemand helfen: Ich möchte per VBA aus Excel heraus die Diagrammdaten aus einer geöffneten PowerPoint-Präsentation öffnen und in die Excel kopieren. Hintergrund: Die PowerPoints werden in einem anderen System generiert und das Kopieren nach Excel dient der Qualitätssicherung. Es geht um Präsentationen mit ca. 50 Diagrammen, davon häufig mehrere auf einem Chart.
Ich habe folgenden Code gebastelt, der auch funktioniert, wenn ich ihn in Einzelschritten _ ablaufen lasse. Bei einem normalen Ablauf tritt aber an scheinbar wahllosen Stellen das Problem auf, dass nicht die Datentabelle des PowerPoint-Diagramms nach dem Kopieren geschlossen wird, sondern die Zieldatei in Excel. Ich habe mit verschiedenen Versionen gespielt die Datentabelle mit und ohne Activate zu kopieren, das Problem tritt aber insbesondere bei großen Präsentationen immer wieder auf. Habt Ihr eine Idee? Hier der Code:
Sub PPTAuslesen()
Dim zeile, slnr, i As Integer
Dim pptApp, ppFile, ppSlide, ppShape As Object
Dim wks As Worksheet
Dim datawkb As Workbook
Set pptApp = GetObject(, "PowerPoint.Application")
Application.ScreenUpdating = False
On Error Resume Next
'Durchläuft die Slides
Set ppFile = pptApp.ActivePresentation
For Each ppSlide In ppFile.Slides
'Startwert für Zeilensprung
zeile = 1
'Neues Arbeitsblatt am Ende einfügen und mit der SlideNr. benennen
slnr = ppSlide.slidenumber
ThisWorkbook.Activate
ThisWorkbook.Sheets.Add _
After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Name = "Slide" & slnr
Set wks = ThisWorkbook.ActiveSheet
'Shapes durchlaufen und Datentabelle kopieren
For Each ppShape In ppSlide.Shapes
If ppShape.Type = msoChart Then
ppShape.Chart.ChartData.Activate
Set datawkb = ActiveWorkbook
datawkb.Sheets(1).UsedRange.Copy
wks.Cells(zeile, 4).PasteSpecial Paste:=xlPasteValues
datawkb.Close
zeile = zeile + 15
End If
Next ppShape
Next ppSlide
'Leere Slides löschen
For i = ThisWorkbook.Sheets.Count To 1 Step -1
If WorksheetFunction.CountA(Worksheets(i).Cells) = 0 Then
Application.DisplayAlerts = False
Worksheets(i).Delete
Application.DisplayAlerts = True
End If
Next i
On Error GoTo 0
Set pptApp = Nothing
End Sub
Vielen Dank, Marco