Results 1 to 3 of 3

Thread: Get Chart's Source Data VBA

  1. #1
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10

    Lightbulb 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

  2. #2
    Senior Member
    Join Date
    Apr 2011
    Posts
    190
    Rep Power
    14
    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
    Attached Files Attached Files
    xl2007 - Windows 7
    xl hates the 255 number

  3. #3
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    Hi Rasm,

    I have modified my code little bit.

    You command code would be

    Code:
    Dim Chart_Object As ChartObject
    Set Chart_Object = ActiveSheet.ChartObjects(1)
    Call GetChartData(Chart_Object)
    Use the above modified code.
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

Similar Threads

  1. Replies: 1
    Last Post: 05-03-2013, 04:41 PM
  2. Replies: 2
    Last Post: 04-26-2013, 04:59 PM
  3. Excel to Excel Data transfer without opening any of the files(source or target)
    By Transformer in forum Excel and VBA Tips and Tricks
    Replies: 14
    Last Post: 08-22-2012, 10:57 AM
  4. VBA code to copy data from source workbook
    By Howardc in forum Excel Help
    Replies: 1
    Last Post: 07-30-2012, 09:28 AM
  5. 2007 PPT Chart Data is not Reflecting In Chart
    By littleiitin in forum Powerpoint Help
    Replies: 2
    Last Post: 04-28-2012, 01:42 PM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •