Extract data labels from a chart in PowerPoint to Excel

Posted on

Problem

Would like to check if anyone here is able to simplify the following code.
What it does: Extract data labels value from a chart in powerpoint to excel.

Sub Extract_Datalabels3()
'Goal: To extract datalabels of Chart's series collection and write to excel
'Working

    Dim sh As Shape
    Dim sld As slide
    Dim chtnow As Chart


    Dim x As Integer
    Dim z As Integer

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


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

Set chtnow = ActiveWindow.Selection.ShapeRange(1).Chart

z = ActiveWindow.Selection.ShapeRange(1).Chart.SeriesCollection(1).DataLabels.Count

For x = 1 To z
xlWorkbook.Sheets(1).Range("A" & x).Value = chtnow.SeriesCollection(1).DataLabels(x).Text
Next

For x = 1 To z
xlWorkbook.Sheets(1).Range("B" & x).Value = chtnow.SeriesCollection(2).DataLabels(x).Text
Next

For x = 1 To z
xlWorkbook.Sheets(1).Range("C" & x).Value = chtnow.SeriesCollection(3).DataLabels(x).Text
Next

For x = 1 To z
xlWorkbook.Sheets(1).Range("D" & x).Value = chtnow.SeriesCollection(4).DataLabels(x).Text
Next

For x = 1 To z
xlWorkbook.Sheets(1).Range("E" & x).Value = chtnow.SeriesCollection(5).DataLabels(x).Text
Next

For x = 1 To z
xlWorkbook.Sheets(1).Range("F" & x).Value = chtnow.SeriesCollection(6).DataLabels(x).Text
Next

For x = 1 To z
xlWorkbook.Sheets(1).Range("G" & x).Value = chtnow.SeriesCollection(7).DataLabels(x).Text
Next

For x = 1 To z
xlWorkbook.Sheets(1).Range("H" & x).Value = chtnow.SeriesCollection(8).DataLabels(x).Text
Next

For x = 1 To z
xlWorkbook.Sheets(1).Range("I" & x).Value = chtnow.SeriesCollection(9).DataLabels(x).Text
Next

For x = 1 To z
xlWorkbook.Sheets(1).Range("J" & x).Value = chtnow.SeriesCollection(10).DataLabels(x).Text
Next

End Sub

Solution

Would this work instead of all the loops:

For a = 1 To 10
    For x = 1 To z
        xlWorkbook.Sheets(1).Cells(x, a) = chtnow.SeriesCollection(a).DataLabels(x).Text
    Next
Next a

Even better than @Vityata’s answer is to extract the labels into an array, then dump the array all at once into the worksheet.

Note I’m using better variable names.

Dim OutputArray() As Variant
Redim OutputArray(1 To PointCount, 1 To SeriesCount)
For PointIndex = 1 To PointCount
  For SeriesIndex = 1 To SeriesCount
    OutputArray(PointIndex, SeriesIndex) = chtnow.SeriesCollection(SeriesIndex).DataLabels(PointIndex).Text
  Next
Next
xlWorkbook.Worksheets(1).Range("A1").Resize(PointIndex, SeriesIndex).Value = OutputArray

Leave a Reply

Your email address will not be published. Required fields are marked *