Question

我需要找到一种方法将图表数据标签从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

Answer 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之类的操作。

Answer 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

使用VBA

2 个答案: