Question

我找到了解决这个问题的方法（Retrieve excel chart data from powerpoint slide (programmatically)），但我无法使其工作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图表，并将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

Answer 2

还有另一种方法。 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

将Powerpoint中的图表数据提取到剪贴板（VBA代码几乎可以正常工作）

2 个答案: