Get Chart's Source Data VBA

[Admin]

Hi All,

Here is method to retrieve the chart's source data.

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

[Rasm]

Kris
I copied your code into my chart test program - Module 2 - However I get an error when I try to execute

I can find a lot of use for this feature - so hopefully it is something small.
Thanks
Rasm

[Admin]

Hi Rasm,

I have modified my code little bit.

You command code would be

Dim Chart_Object As ChartObject
Set Chart_Object = ActiveSheet.ChartObjects(1)
Call GetChartData(Chart_Object)

Use the above modified code.