"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.
Function hackChart(iSeries) As Variant()
Dim ch As Chart
Dim sh As Shape
Dim ss As Series
'set shape to selected object
Set sh = ActiveWindow.Selection.ShapeRange(1)
If sh.HasChart = False Then
MsgBox ("This shape does not have a chart")
Exit Function
End If
Set ch = sh.Chart
Set ss = ch.SeriesCollection(iSeries)
hackChart = ss.Values
End Function
Option Explicit
Dim pptApp As PowerPoint.Application
Sub hackChart()
Dim ch As PowerPoint.Chart
Dim sh As PowerPoint.Shape
Dim ss As PowerPoint.Series
Dim ax As PowerPoint.Axis
Dim pSel As PowerPoint.Selection
Dim iCount As Long, iSeries As Long, iRow As Long
Dim rChart As Range, rSeries As Range
Dim aSeries() As Variant, xlSeries() As Variant
On Error GoTo errortrap
If connectPPT Then
'set shape to selected object, ro abort if no chart selected
Set sh = pptApp.ActiveWindow.Selection.ShapeRange(1)
If sh.HasChart = False Then
MsgBox ("Selected Powerpoint shape is not a chart")
Exit Sub
End If
'clear previous chart data
Set rChart = [cChartStart].CurrentRegion
rChart.ClearContents
Set rChart = rChart.Resize(1, 1)
'access the chart in the shape
Set ch = sh.Chart
'get the X-axis title
Set ax = ch.Axes(xlCategory)
If ax.HasTitle Then
rChart = ax.AxisTitle
Else
rChart = "X-Axis"
End If
'get X axis values
Set ss = ch.SeriesCollection(1)
aSeries = ss.XValues
'Convert to Excel compatible array
ReDim xlSeries(1 To UBound(aSeries), 1 To 1)
For iRow = 1 To UBound(aSeries)
xlSeries(iRow, 1) = aSeries(iRow)
Next
Set rSeries = rChart.Offset(1, 0).Resize(UBound(aSeries), 1)
'put values in range "rSeries"
rSeries = xlSeries
'get each data series
For iSeries = 1 To ch.SeriesCollection.Count
'move one column to the right in Excel
Set rChart = rChart.Offset(0, 1)
Set ss = ch.SeriesCollection(iSeries)
'add series name
rChart = ss.Name
'get series values
aSeries = ss.Values
'Convert to Excel compatible array
ReDim xlSeries(1 To UBound(aSeries), 1 To 1)
For iRow = 1 To UBound(aSeries)
xlSeries(iRow, 1) = aSeries(iRow)
Next
Set rSeries = rChart.Offset(1, 0).Resize(UBound(aSeries), 1)
'put series values in excel range
rSeries = xlSeries
Next
End If
Exit Sub
errortrap:
MsgBox "An error has occurred. Please check Powerpoint is open and a chart selected."
End Sub
Function connectPPT() As Boolean
'see if PPT is open:
Set pptApp = GetObject(, "Powerpoint.Application")
'if not
If TypeName(pptApp) = "Nothing" Then
MsgBox ("Powerpoint must be running for this routine to work")
Exit Function
End If
connectPPT = True
End Function
From novice to tech pro — start learning today.