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

我找到了这个（）的解决方案，但我无法让它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

---

我没有使用剪贴板，这可能会有问题。相反，我循环浏览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

---

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

---

您需要剪贴板中的数据吗？我总是发现将数据放入VBA数组并以这种方式处理更可靠、更容易混淆。一点也不！我只是想找到一条出路，但我还没有找到可以自己编写VBA的地方。我在网上搜索时发现了这张剪报。您介意共享您使用的VBA吗？您希望数据最终到达哪里？工作表？我可以给你一些代码来提取数据，将其放入工作表的列中，在顶部有一些信息（如演示路径和名称、幻灯片编号、图表名称或编号）。工作表会很棒，谢谢！我正在将旧的图表数据添加到新的演示文稿中，因此我基本上只需将旧的信息（值和标签）粘贴到新的图表中，但将其放在另一个工作表中，我就可以从那里复制它。我提供了PowerPoint代码，而不是工作表，它可以将数据吐出到Excel工作表中。这是一个完美的解决方案，谢谢！尝试运行VBA后，出现“用户定义类型未定义”错误，指向（Dim）“wb As工作簿”。我试着在谷歌上搜索解决方案，但没有找到任何相关的。这个脚本适合你吗？我在MacOS上，Powerpoint 16.22。设置对Excel对象模型的引用。在VB编辑器中，转到“工具”菜单>“引用”，然后向下滚动到Microsoft Excel 16.0对象库，选中该框，然后单击“确定”。感谢您的帮助！我设法克服了第一个错误，但现在我遇到了一个不同的错误：在演示文稿中选择单个图表时，出现了错误“运行时错误'13'：类型不匹配”，指向“Set wb=chtdat.Workbook”。当我选择所有幻灯片时，出现以下错误：运行时错误'.2147188160（80048240）''：选择（未知成员：无效请求。此视图不支持选择），指向“Set cht=ActiveWindow.Selection.shaperage.Parent.Shapes(ActiveWindow.Selection.shaperage.Name）.Chart”你是如何避开第一个错误的？你确定了推荐人吗？最好将wb设置为Excel.Workbook。该代码并不适用于所有幻灯片，它只适用于一张幻灯片上选定的图表。几乎没有任何错误检查，因此如果您没有选择形状，或者形状不是图表，则会出现错误。如果要导出所有图表的所有数据，必须循环浏览所有幻灯片，然后浏览每张幻灯片上的所有形状，测试它是否为图表，然后确保导出的数据使用唯一的文件名。或者修改我的另一个答案中的代码，以便将每个图表的数据提取到工作簿的新页上。