使用 VBA 将 Powerpoint 图表标签提取到 Excel答案

【问题标题】：Extract Powerpoint chart label to Excel using VBA使用 VBA 将 Powerpoint 图表标签提取到 Excel
【发布时间】：2018-06-07 11:23:29
【问题描述】：

我需要找到一种方法来将图表数据标签从 PowerPoint 图表提取到 Excel，因为给我的 PowerPoint 图表很多次都损坏了链接数据。

我写了下面的代码，但我不知道For Each datapoint In chtnow.SeriesCollection(1).Points...之后要做什么

Sub Extract_Datalabels()
'Goal: To extract datalabels of Chart's series collection and write to excel        
    Dim datapoint As Point
    Dim sh As Shape
    Dim sld As Slide
    Dim chtnow As Chart
    Dim label As DataLabel
    Dim xlApp As New Excel.Application
    Dim xlWorkbook As Excel.Workbook
    Dim xlworksheet As Excel.Worksheet

    Set xlWorkbook = xlApp.Workbooks.Add
    Set xlworksheet = xlWorksheets.Add
    xlApp.Visible = True

    Set chtnow = ActiveWindow.Selection.ShapeRange(1).Chart
    For Each datapoint In chtnow.SeriesCollection(1).Points
    'Extract data labels
        If datapoint.HasDataLabel Then

            [No clue how to write to Excel]

        End If
    Next
End Sub

【问题讨论】：

这不是一个例子，但它已经有问题了。代码应该在发布之前进行测试。（见minimal reproducible example）
另外，在 [每个] 模块的顶部 [总是] 使用 Option Explicit。

标签： excel vba charts label powerpoint

【解决方案1】：

如果代码中其他一切正常，这是在 excel 中写入 xlworksheet 第一列的简单方法：

Dim cnt As Long
If datapoint.HasDataLabel Then
    cnt = cnt + 1
    xlworksheet.Cells(cnt, 1) = datapoint.label
End If

但是，我不确定在设置xlApp.Visible = True 后，您是否可以执行类似Set chtnow = ActiveWindow.Selection.ShapeRange(1).Chart 的操作。

【讨论】：

这应该没有问题，因为 Excel 和 PPT 维护自己的（和独立的）窗口集合。

【解决方案2】：

您的示例有几个类型错误，但这应该可以为您完成工作。您需要添加对Microsoft Excel [A Number] Object Library 的引用才能使用Excel 对象类型和所有派生类。

所有测试均使用条形图完成。

Sub Extract_Datalabels()
''Goal: To extract datalabels of Chart's series collection and write to excel
    Dim datapoint   As ChartPoint
    Dim chtnow      As Chart

    Dim xlApp       As New Excel.Application
    Dim xlWorkbook  As Excel.Workbook
    Dim xlworksheet As Excel.Worksheet
    Dim Row         As Long

    Let xlApp.SheetsInNewWorkbook = 1

    Set xlWorkbook = xlApp.Workbooks.Add
    Set xlworksheet = xlWorkbook.Worksheets(1)
    Let xlApp.Visible = True
    Call VBA.DoEvents

    Set chtnow = ActiveWindow.Selection.ShapeRange(1).Chart
    Let Row = 1
    For Each datapoint In chtnow.SeriesCollection(1).Points
        'Extract data labels
        If datapoint.HasDataLabel Then
            Let xlworksheet.Cells(Row, 1) = datapoint.DataLabel.Text
        End If
        Let Row = Row + 1
    Next
End Sub

【讨论】：