Extract chart data in powerpoint to clipboard (VBA-code almost working)

Question

I found a solution to this ( Retrieve excel chart data from powerpoint slide (programmatically) ), but I cannot get it to work 100%. After I execute the VBA, I get the message saying "successfully copied to clipboard", but there is nothing in the clipboard.

Is this VBA working for anyone?

This is the VBA code:

    Sub RipChartValues()
Dim cht As PowerPoint.Chart
Dim seriesIndex As Long
Dim labels As Variant
Dim values As Variant
Dim name As String
Dim buffer As String
Dim objData As Object

Set cht = ActiveWindow.Selection.ShapeRange.Parent.Shapes(ActiveWindow.Selection.ShapeRange.name).Chart

With cht
    For seriesIndex = 1 To .SeriesCollection.Count
    name = .SeriesCollection(seriesIndex).name
    labels = .SeriesCollection(seriesIndex).XValues
    values = .SeriesCollection(seriesIndex).values

    If seriesIndex = 1 Then buffer = vbTab & Join(labels, vbTab) & vbCrLf
    buffer = buffer & (name & vbTab & Join(values, vbTab) & vbCrLf)
    Next

End With

On Error Resume Next
' Rory's late bind example
' this is a late bound MSForms.DataObject
Set objData = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

' copy current cell formula to clipboard
With objData
    .SetText buffer
    .PutInClipboard
    MsgBox "Data extracted to clipboard!", vbOKOnly, "Success"
End With

End Sub

Answer 1

I didn't use the clipboard, which can be problematic. Instead, I looped through the PowerPoint chart, and dumped the X and Y values and series name into a new Excel worksheet.

Here's the code:

Sub ExtractChartValues()
  '' Set reference to Microsoft Excel Object Library

  ' find running Excel application
  Dim xlApp As Excel.Application
  On Error Resume Next
  Set xlApp = GetObject(, "Excel.Application")
  On Error GoTo 0
  If xlApp Is Nothing Then
    ' Excel not running, so start it up
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
  End If

  ' worksheet to output chart data
  Dim ws As Excel.Worksheet
  Set ws = xlApp.Workbooks.Add.Worksheets(1)

  Dim cht As PowerPoint.Chart
  Set cht = ActiveWindow.Selection.ShapeRange.Parent.Shapes _
      (ActiveWindow.Selection.ShapeRange.Name).Chart
  Dim ixSeries As Long
  ' loop through series in chart
  For ixSeries = 1 To cht.SeriesCollection.Count
    Dim srs As Series
    Set srs = cht.SeriesCollection(ixSeries)
    Dim SrsName As String
    SrsName = srs.name
    Dim SrsXVals As Variant
    SrsXVals = srs.XValues
    Dim SrsYVals As Variant
    SrsYVals = srs.values
    ' output: pair of columns for each series
    '         first column: blank first row, X values below
    '         second column: name in first row, Y values below
    ws.Cells(1, ixSeries * 2).Value = SrsName
    ws.Cells(2, ixSeries * 2 - 1).Resize(UBound(SrsXVals) + 1 - LBound(SrsXVals)).Value = _
        WorksheetFunction.Transpose(SrsXVals)
    ws.Cells(2, ixSeries * 2).Resize(UBound(SrsYVals) + 1 - LBound(SrsYVals)).Value = _
        WorksheetFunction.Transpose(SrsYVals)
  Next
End Sub

Answer 2

There's an alternative approach. The PowerPoint chart stores its data in something called a ChartData object, and this is basically comprised of an Excel workbook, embedded in the slide with the chart.

Here's some PowerPoint VBA code that saves the workbook, so you can simply open it in Excel:

Sub ExportChartDataSheet()
  Dim cht As PowerPoint.Chart
  Set cht = ActiveWindow.Selection.ShapeRange.Parent.Shapes _
      (ActiveWindow.Selection.ShapeRange.name).Chart
  Dim chtdat As ChartData
  Set chtdat = cht.ChartData
  Dim wb As Excel.Workbook
  Set wb = chtdat.Workbook
  Dim IsVisible As Boolean
  IsVisible = wb.Windows(1).Visible
  If Not IsVisible Then
    wb.Windows(1).Visible = True
  End If
  Dim sFileName As String
  sFileName = Left$(ActivePresentation.FullName, InStrRev(ActivePresentation.FullName, ".") - 1) _
      & "_" & ActiveWindow.Selection.ShapeRange.name & "_Output.xlsx"
  wb.SaveAs sFileName, xlOpenXMLWorkbook
  wb.Windows(1).Visible = IsVisible
End Sub