VBA Macro to extract data from a chart in Excel 2007, 2010, and 2013

Question

I was sent an Excel sheet that with 4 charts. The data for the charts is in another workbook that was not provided.

Goal: I want to extract the data from the charts using a VBA sub.

Problem: I am having some trouble with "type mismatch." When I try to assign the Variant array oSeries.XValues to a Range of cells.

Option Explicit
Option Base 1
' 1. Enter the following macro code in a module sheet.
' 2. Select the chart from which you want to extract the underlying data values.
' 3. Run the GetChartValues Sub. The data from the chart is placed in a new worksheet named "ChartName Data".
'
Sub GetChartValues()
    '
    Dim lxNumberOfRows As Long
    Dim lyNumberOfRows As Long
    Dim oSeries As Series
    Dim lCounter As Long
    Dim oWorksheet As Worksheet
    Dim oChart As Chart
    Dim xValues() As Variant
    Dim yValues() As Variant
    Dim xDestination As Range
    Dim yDestination As Range


    Set oChart = ActiveChart
    ' If a chart is not active, just exit
    If oChart Is Nothing Then
        Exit Sub
    End If

    ' Create the worksheet for storing data
    Set oWorksheet = ActiveWorkbook.Worksheets.Add
    oWorksheet.Name = oChart.Name & " Data"


    ' Loop through all series in the chart and write there values to
    ' the worksheet.
    lCounter = 1
    For Each oSeries In oChart.SeriesCollection

        xValues = oSeries.xValues
        yValues = oSeries.values

        ' Calculate the number of rows of data. 1048576 is maximum number of rows in excel.
        lxNumberOfRows = WorksheetFunction.Min(UBound(oSeries.xValues), 1048576 - 1)
        lyNumberOfRows = WorksheetFunction.Min(UBound(oSeries.values), 1048576 - 1)

        ' Sometimes the Array is to big, so chop off the end
        ReDim Preserve xValues(lxNumberOfRows)
        ReDim Preserve yValues(lyNumberOfRows)


        With oWorksheet
            ' Put the name of the series at the top of each column
            .Cells(1, 2 * lCounter - 1) = oSeries.Name
            .Cells(1, 2 * lCounter) = oSeries.Name

            Set xDestination = .Range(.Cells(1, 2 * lCounter - 1), .Cells(lxNumberOfRows + 1, 2 * lCounter - 1))
            Set yDestination = .Range(.Cells(1, 2 * lCounter), .Cells(lxNumberOfRows + 1, 2 * lCounter))

            'Assign the x and y data from the chart to a range in the worksheet
             xDestination.value = Application.Transpose(xValues)
             yDestination.value = Application.Transpose(yValues)

            ' This does not work either
            ' .Range(.Cells(2, 2 * lCounter - 1), .Cells(lxNumberOfRows + 1, 2 * lCounter - 1)).value = Application.Transpose(oSeries.xValues)
            ' .Range(.Cells(2, 2 * lCounter), .Cells(lxNumberOfRows + 1, 2 * lCounter)).value = Application.Transpose(oSeries.values)


        End With

        lCounter = lCounter + 1
    Next

    ' Cleanup
    Set oChart = Nothing
    Set oWorksheet = Nothing

End Sub

The main issue is the following lines:

.Range(.Cells(2, 2 * lCounter - 1), .Cells(lxNumberOfRows + 1, 2 * lCounter - 1)) = Application.Transpose(oSeries.xValues)
.Range(.Cells(2, 2 * lCounter), .Cells(lxNumberOfRows + 1, 2 * lCounter)) = Application.Transpose(oSeries.values)

Upon further inspection using the Locals window, I find the following:

The below code works while the above code does not.

Sub Test2()
Dim A(6) As Variant
'A(1) = 1
A(2) = 2#
A(3) = 3#
A(4) = 4#
A(5) = 5#
Range(Cells(1, 1), Cells(6, 1)).value = Application.Transpose(A)
End Sub

Why doesn't the first piece of code work?

Looping over many cells is slow in this case (I've tried). Please, don't use a loop unless it is seconds for 1,000,000 element.

Answer 1

The main cause is the built-in Transpose function. Transpose can only handle arrays with 2^16 or less elements.

The code below works well. It handles the problem of Transpose function limitation of 2^16 elements. It uses a for loop but the for loop is fast for arrays. For four series and each having 1048576 elements, the Sub took about 10 seconds to run. This is acceptable.

Option Explicit
Option Base 1
' 1. Enter the following macro code in a module sheet.
' 2. Select the chart from which you want to extract the underlying data values.
' 3. Run the GetChartValues Sub. The data from the chart is placed in a new worksheet named "ChartName Data".
'
Public Sub GetChartValues()

    Dim lxNumberOfRows As Long
    Dim lyNumberOfRows As Long
    Dim oSeries As Series
    Dim lSeriesCounter As Long
    Dim oWorksheet As Worksheet
    Dim oChart As Chart
    Dim xValues() As Variant
    Dim yValues() As Variant
    Dim xDestination As Range
    Dim yDestination As Range


    Set oChart = ActiveChart
    ' If a chart is not active, just exit
    If oChart Is Nothing Then
        Exit Sub
    End If

    ' Create the worksheet for storing data
    Set oWorksheet = ActiveWorkbook.Worksheets.Add
    oWorksheet.Name = oChart.Name & " Data"


    ' Loop through all series in the chart and write their values to the worksheet.
    lSeriesCounter = 1
    For Each oSeries In oChart.SeriesCollection
        ' Get the x and y values
        xValues = oSeries.xValues
        yValues = oSeries.values

        ' Calculate the number of rows of data.
        lxNumberOfRows = UBound(xValues)
        lyNumberOfRows = UBound(yValues)

        ' 1048576 is maximum number of rows in excel. Sometimes the Array is too big. Chop off the end.
        If lxNumberOfRows >= 1048576 Then
            lxNumberOfRows = 1048576 - 1
            ReDim Preserve xValues(lxNumberOfRows)
        End If
        If lyNumberOfRows >= 1048576 Then
            lyNumberOfRows = 1048576 - 1
            ReDim Preserve yValues(lyNumberOfRows)
        End If

        With oWorksheet
            ' Put the name of the series at the top of each column
            .Cells(1, 2 * lSeriesCounter - 1) = oSeries.Name & " X Values"
            .Cells(1, 2 * lSeriesCounter) = oSeries.Name & " Y Values"
            Set xDestination = .Range(.Cells(2, 2 * lSeriesCounter - 1), .Cells(lxNumberOfRows + 1, 2 * lSeriesCounter - 1))
            Set yDestination = .Range(.Cells(2, 2 * lSeriesCounter), .Cells(lxNumberOfRows + 1, 2 * lSeriesCounter))
        End With


        ' Arrays larger than 2^16 will fail with Transpose function. Therefore must manually transpose
        If lxNumberOfRows > 2& ^ 16 Then

            'Assign the x and y data from the chart to a range in the worksheet. Use the ManualTranspose for  2^16 or more elements.
             xDestination.value = ManualTranspose(xValues)
             yDestination.value = ManualTranspose(yValues)
        Else

            'Assign the x and y data from the chart to a range in the worksheet. Use the built-in Transpose for less than 2^16 elements.
            xDestination.value = WorksheetFunction.Transpose(xValues)
            yDestination.value = WorksheetFunction.Transpose(yValues)
        End If

        lSeriesCounter = lSeriesCounter + 1
    Next

    ' Cleanup
    Set oChart = Nothing
    Set oWorksheet = Nothing

End Sub

' Helper function for when built-in Transpose function cannot be used. Arrays larger than 2^16 must be transposed manually.
Private Function ManualTranspose(ByRef arr As Variant) As Variant
    Dim arrLength As Long
    Dim i As Long
    Dim TransposedArray() As Variant

    arrLength = UBound(arr)

    ReDim TransposedArray(arrLength, 1)

    For i = 1 To arrLength
        TransposedArray(i, 1) = arr(i)
    Next i

    ManualTranspose = TransposedArray
End Function