Get Chart's Source Data VBA
Hi All,
Here is method to retrieve the chart's source data.
Code:
Option Explicit
'// Author : Krishnakumar @ ExcelFox.com
'// Created on : 18-Nov-2011
'// Purpose : Creates a new workbook with Chart's data
Sub GetChartData(ByRef Chart_Object As ChartObject)
Dim chtChart As Chart
Dim pntPoint As Point
Dim lngLoop As Long
Dim lngLoopSrs As Long
Dim lngSrsCount As Long
Dim lngPlotBy As Long
Dim lngChartType As Long
Dim lngSU As Long
Dim lngSecSrsCnt As Long
Dim wbkActive As Workbook
Dim wbkNew As Workbook
Dim wksNew As Worksheet
Dim varArrYVals() As String
Dim strNumFormatHeader As String
Dim strNumFormatData As String
Dim strNumFormatDataSec As String
Dim strFmla As String
Dim strShtName As String
Dim strRange As String
Dim strListSep As String
Dim strAcell As String
Dim blnHasLabel As Boolean
Dim blnFlag As Boolean
Dim blnSizeStored As Boolean
Dim lngArrSecSrs() As Long
Dim varArrOutput() As Variant
Dim varXVal As Variant
Dim varYVal As Variant
Dim varVal As Variant
Dim varSpltFmla As Variant
Dim varSpltRange As Variant
With Application
lngSU = .ScreenUpdating
.ScreenUpdating = False
.EnableEvents = False
End With
Set wbkActive = ThisWorkbook
strAcell = ActiveCell.Address
Set chtChart = Chart_Object.Chart
lngPlotBy = chtChart.PlotBy
lngSrsCount = chtChart.SeriesCollection.Count
lngChartType = CLng(chtChart.ChartType)
Select Case lngChartType
Case -4111, 51, 52, 57, 58, 65, 93, 94 'Line,Column,Bar
ReDim varArrOutput(1 To lngSrsCount + 1)
ReDim varArrYVals(1 To lngSrsCount + 1)
varXVal = chtChart.SeriesCollection(1).XValues
varArrOutput(1) = varXVal
varArrYVals(1) = vbNullString
On Error Resume Next
varYVal = chtChart.Axes(1, 1).CategoryNames
strNumFormatHeader = chtChart.Axes(1, xlPrimary).TickLabels.NumberFormat
If strNumFormatHeader = vbNullString Then strNumFormatHeader = "@"
strNumFormatData = chtChart.Axes(2, xlPrimary).TickLabels.NumberFormat
strNumFormatDataSec = chtChart.Axes(2, xlSecondary).TickLabels.NumberFormat
On Error GoTo 0
If strNumFormatDataSec = vbNullString Then blnFlag = True
For lngLoopSrs = 1 To lngSrsCount
varVal = chtChart.SeriesCollection(lngLoopSrs).Values
If Not blnFlag Then
If chtChart.SeriesCollection(lngLoopSrs).AxisGroup = 2 Then
lngSecSrsCnt = lngSecSrsCnt + 1
ReDim Preserve lngArrSecSrs(1 To lngSecSrsCnt)
lngArrSecSrs(lngSecSrsCnt) = lngLoopSrs
End If
End If
varArrOutput(lngLoopSrs + 1) = varVal
varArrYVals(lngLoopSrs + 1) = chtChart.SeriesCollection(lngLoopSrs).Name
Next
Case -4102, 5, 69, 70 'Pie
ReDim varArrOutput(1 To lngSrsCount + 1)
ReDim varArrYVals(1 To lngSrsCount + 1)
varXVal = chtChart.SeriesCollection(1).XValues
varArrOutput(1) = varXVal
varArrYVals(1) = vbNullString
On Error Resume Next
Set pntPoint = chtChart.SeriesCollection(1).Points(1)
blnHasLabel = pntPoint.HasDataLabel
varYVal = chtChart.Axes(1, 1).CategoryNames
strNumFormatHeader = chtChart.Axes(1, xlPrimary).TickLabels.NumberFormat
If strNumFormatHeader = vbNullString Then strNumFormatHeader = "@"
If Not blnHasLabel Then
pntPoint.HasDataLabel = True
End If
strNumFormatData = pntPoint.DataLabel.NumberFormat
pntPoint.HasDataLabel = blnHasLabel
varArrYVals(2) = chtChart.SeriesCollection(1).Name
varVal = chtChart.SeriesCollection(1).Values
varArrOutput(2) = varVal
On Error GoTo 0
Case 87 'Bubble
strListSep = Application.International(5)
ReDim varArrOutput(1 To lngSrsCount, 1 To 4)
strShtName = Replace(chtChart.Parent.Parent.Name, "'", "''")
Application.Goto wbkActive.Worksheets(CStr(strShtName)).Range(CStr(strAcell))
For lngLoopSrs = 1 To lngSrsCount
strFmla = chtChart.SeriesCollection(lngLoopSrs).Formula
strFmla = Mid$(strFmla, InStr(1, strFmla, "(") + 1)
strFmla = Replace(Replace(Replace(strFmla, strShtName, ""), "!", ""), ")", "")
varSpltFmla = Split(strFmla, strListSep)
strRange = vbNullString
For lngLoop = 0 To UBound(varSpltFmla)
If varSpltFmla(lngLoop) Like "$*$#*" Or varSpltFmla(lngLoop) Like "$*$#*:$*$#*" Then
strRange = strRange & strListSep & varSpltFmla(lngLoop)
ElseIf varSpltFmla(lngLoop) Like "{#*}" Then
varArrOutput(lngLoopSrs, 4) = CSng(Replace(Replace(varSpltFmla(lngLoop), "{", ""), "}", ""))
blnSizeStored = True
End If
Next
If Len(strRange) > Len(strListSep) Then
strRange = Mid$(strRange, Len(strListSep) + 1)
varSpltRange = Split(strRange, strListSep)
varArrOutput(lngLoopSrs, 1) = Evaluate("'" & strShtName & "'!" & varSpltRange(0))
varArrOutput(lngLoopSrs, 2) = Evaluate("'" & strShtName & "'!" & varSpltRange(1))
varArrOutput(lngLoopSrs, 3) = Evaluate("'" & strShtName & "'!" & varSpltRange(2))
If Not blnSizeStored Then
varArrOutput(lngLoopSrs, 4) = Evaluate("'" & strShtName & "'!" & varSpltRange(3))
End If
End If
blnSizeStored = False
Next
On Error Resume Next
Set pntPoint = chtChart.SeriesCollection(1).Points(1)
blnHasLabel = pntPoint.HasDataLabel
varYVal = chtChart.Axes(1, 1).CategoryNames
strNumFormatHeader = chtChart.Axes(1, xlPrimary).TickLabels.NumberFormat
If strNumFormatHeader = vbNullString Then strNumFormatHeader = "@"
If Not blnHasLabel Then
pntPoint.HasDataLabel = True
End If
strNumFormatData = pntPoint.DataLabel.NumberFormat
pntPoint.HasDataLabel = blnHasLabel
On Error GoTo 0
Case Else
GoTo Xit
End Select
Set wbkNew = Workbooks.Add(-4167)
Set wksNew = wbkNew.Worksheets(1)
If lngPlotBy = 1 Then
For lngLoop = 1 To UBound(varArrOutput)
wksNew.Cells(lngLoop, 1) = varArrYVals(lngLoop)
wksNew.Cells(lngLoop, 2).Resize(, UBound(varArrOutput(lngLoop), 1)) = varArrOutput(lngLoop)
Next
wksNew.Cells(2, 2).Resize(UBound(varArrOutput), UBound(varArrOutput(1), 1)).NumberFormat = strNumFormatData
On Error Resume Next
wksNew.Cells(1, 2).Resize(, UBound(varYVal)).NumberFormat = "@"
wksNew.Cells(1, 2).Resize(, UBound(varYVal)) = varYVal
If Err.Number <> 0 Then
wksNew.Cells(1, 2).Resize(, UBound(varArrOutput(1), 1)).NumberFormat = "@"
wksNew.Cells(1, 2).Resize(, UBound(varArrOutput(1), 1)) = varYVal
Err.Clear
End If
If Not blnFlag Then
For lngLoop = 1 To lngSecSrsCnt
wksNew.Cells(1 + lngArrSecSrs(lngLoop), 2).Resize(, UBound(varArrOutput(lngLoop), 1)).NumberFormat = strNumFormatDataSec
Next
End If
ElseIf lngPlotBy = 0 Then
Select Case lngChartType
Case 87
With wksNew.Range("a2")
.Resize(UBound(varArrOutput, 1), UBound(varArrOutput, 2)) = varArrOutput
.OffSet(, 1).Resize(UBound(varArrOutput, 1), UBound(varArrOutput, 2) - 1).NumberFormat = strNumFormatData
End With
Case Else
GoTo 2
End Select
ElseIf lngPlotBy = 2 Then
2:
On Error Resume Next
For lngLoop = 1 To UBound(varArrOutput)
wksNew.Cells(1, lngLoop) = varArrYVals(lngLoop)
wksNew.Cells(2, lngLoop).Resize(UBound(varArrOutput(lngLoop), 1)) = Application.Transpose(varArrOutput(lngLoop))
Next
Err.Clear
wksNew.Cells(2, 1).Resize(UBound(varYVal)).NumberFormat = "@"
If Err.Number <> 0 Then
wksNew.Cells(2, 1).Resize(UBound(varArrOutput(1), 1)).NumberFormat = "@"
Err.Clear
End If
wksNew.Cells(2, 1).Resize(UBound(varYVal)) = Application.Transpose(varYVal)
wksNew.Cells(2, 2).Resize(UBound(varArrOutput(1), 1), UBound(varArrOutput)).NumberFormat = strNumFormatData
If Not blnFlag Then
For lngLoop = 1 To lngSecSrsCnt
wksNew.Cells(2, 1 + lngArrSecSrs(lngLoop)).Resize(UBound(varArrOutput(1), 1), UBound(varArrOutput)).NumberFormat = strNumFormatDataSec
Next
End If
End If
wksNew.UsedRange.Columns.AutoFit
Xit:
If Err.Number <> 0 Then Err.Clear: On Error GoTo 0
With Application
.ScreenUpdating = lngSU
.ScreenUpdating = True
End With
End Sub
