Hi Forum,

vielleicht kann jemand helfen: Ich möchte aus Excel heraus die Datentabellen aus allen Diagrammen einer PowerPoint-Datei in die Excel kopieren (Office 2016). Das funktioniert im Prinzip, schlägt aber an scheinbar wahlloser Stelle immer wieder fehl. Laut Fehlermeldung ist entweder Chartdata.Workbook.Activate fehlgeschlagen oder das PasteSpecial funktioniert nicht. Es handelt sich bei mehreren Durchläufen nicht immer um dasselbe Diagramm. Alle Versuche mit Loops den fehlgeschlagenen Prozess einfach zu wiederholen funktionieren nicht. Aufgefallen ist mir nur, dass ich die jeweilige Datendatei in PowerPoint selbst öffnen kann, sie heißt dann aber nicht wie sonst "Diagramm in PowerPoint" sondern "Mappe xy". Hat jemand eine Idee, warum das instabil ist? 

Vielen Dank, Marco

Sub PPTAuslesen()

    Dim zeile As Integer
    Dim pptApp As PowerPoint.Application
    Dim ppFile As PowerPoint.Presentation
    Dim ppSlide As PowerPoint.Slide
    Dim ppShape As PowerPoint.Shape
    Dim ppChart As PowerPoint.Chart
    Dim ppChartData As PowerPoint.ChartData
    Dim wks As Excel.Worksheet
    Dim ppdatawkb As Excel.Workbook
           
    Set pptApp = GetObject(, "PowerPoint.Application")
    Set ppFile = pptApp.ActivePresentation

    Set wks = ThisWorkbook.ActiveSheet
    zeile = 1

    For Each ppSlide In ppFile.Slides
        For Each ppShape In ppSlide.Shapes
            If ppShape.Type = msoChart Then
                Set ppChart = ppShape.Chart
                Set ppChartData = ppChart.ChartData
                ppChartData.Activate
                Set ppdatawkb = ppChartData.Workbook
                ppdatawkb.Sheets(1).UsedRange.Copy
                wks.Cells(zeile, 4).PasteSpecial xlValues
                ppdatawkb.Close
                zeile = zeile + 20
                Set ppdatawkb = Nothing
            End If
        Next ppShape
    Next ppSlide
    
    Set pptApp = Nothing
    Set ppFile = Nothing
    Set ppSlide = Nothing
    Set ppShape = Nothing
    Set ppChart = Nothing
    Set ppChartData = Nothing
    
End Sub