3
\$\begingroup\$

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
\$\endgroup\$
  • 2
    \$\begingroup\$ Welcome to Code Review. The current question title, which states your concerns about the code, applies to too many questions on this site to be useful. The site standard is for the title to simply state the task accomplished by the code. Please see How to Ask for examples, and revise the title accordingly. Also, you could add a little bit more detail how the extracted data should get represented. \$\endgroup\$ – Zeta Jun 8 '18 at 7:38
1
\$\begingroup\$

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
\$\endgroup\$
  • \$\begingroup\$ Thanks Vityata for getting me to the right direction. This works, I just changed .Cells(x,1) to .Cells(x,a) so that it will write on the next column in excel instead of overwriting on column 1 as it loop through the series collection. \$\endgroup\$ – Gerald Tow Jun 8 '18 at 9:53
  • \$\begingroup\$ @GeraldTow - you are welcome. \$\endgroup\$ – Vityata Jun 8 '18 at 9:58
0
\$\begingroup\$

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
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.