Извлечение данных диаграммы в PowerPoint в буфер обмена (VBA-код почти работает)

Question

Я нашел решение этой проблемы ( Извлечение данных диаграммы Excel из слайда PowerPoint (программно) ), но я не могу заставить его работать на 100%.После выполнения VBA я получаю сообщение «успешно скопировано в буфер обмена», но в буфере обмена ничего нет.

Работает ли этот VBA для кого-либо?

Это код VBA:

    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

Есть альтернативный подход.Диаграмма PowerPoint хранит свои данные в объекте, называемом объектом ChartData, и он в основном состоит из рабочей книги Excel, встроенной в слайд с диаграммой.

Вот некоторый код PowerPoint VBA, который сохраняет рабочую книгу, поэтому вы можетепросто откройте его в 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

Answer 2

Я не использовал буфер обмена, что может быть проблематично.Вместо этого я перебрал диаграмму PowerPoint и поместил значения X и Y и имя серии в новый лист Excel.

Вот код:

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