Извлечение метки диаграммы Powerpoint в Excel с использованием VBA - PullRequest
Новая
       22

Извлечение метки диаграммы Powerpoint в Excel с использованием VBA

0 голосов
/ 07 июня 2018

Мне нужно найти способ извлечения меток данных диаграммы из диаграммы 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

Ответы [ 2 ]

0 голосов
/ 07 июня 2018

В вашем примере было несколько ошибок типа, но это должно сделать работу за вас.Вам нужно будет добавить ссылку на 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
0 голосов
/ 07 июня 2018

Если с кодом все остальное работает нормально, это простой способ записи в первый столбец xlworksheet в excel: 

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.

...