VBA宏从Excel 2007、2010和2013中的图表中提取数据

我收到一份Excel表格，上面有4张图表。图表的数据位于另一个未提供的工作簿中

目标：我想使用VBA sub从图表中提取数据

问题：当我尝试将变量数组

oSeries.XValues

分配给一系列单元格时，我遇到了一些“类型不匹配”的问题

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

主要问题如下：

.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)

在使用“本地人”窗口进行进一步检查后，我发现以下情况：

下面的代码有效，而上面的代码无效

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

为什么第一段代码不起作用？

---

在这种情况下，在许多单元格上循环很慢（我已经尝试过）。请不要使用循环，除非1000000元素是秒。

主要原因是内置的

转置功能<代码>转置

只能处理包含2^16或更少元素的数组

下面的代码运行良好。它处理2^16个元素的转置函数限制问题。它使用for循环，但对于阵列，for循环速度很快。对于四个系列，每个系列都有1048576个元素，Sub运行大约需要10秒。这是可以接受的

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

---

我认为将带有

Empty

值的数组分配给工作表没有任何问题-你确定这就是问题所在吗？同意@TimWilliams，我对

Empty

和输出到某个范围没有问题。可能需要在那些

.Range（）

调用的末尾添加

.Value

，以明确您想要的内容。有时，数组输出IIRC可能会出现问题。作为旁注，

Resize

在这样构建

范围时是一个有用的函数。节省了很多错误，可以使用<代码>。但可能与您的问题无关。如果我为第一个元素指定了
Empty
以外的内容，则我没有问题。这就是为什么我关注的是
空的
。当我从一个范围读入数组时，大小是
（1到300，1到1）
。我使用的数组是
（1到1048576）
，因此缺少维度。这与我的问题有关吗？因为这是最大行数，您可能会在
工作表的底部使用
范围
，因为您要向其中添加一行。我相信你所说的
空的
，但是很难把这个问题称为空的，因为我们中有两个人说它很好用。我正在使用Excel 2013来获取它的价值。如果从第1行开始而不是从第2行开始，是否存在问题？我从第1行还是第2行开始并不重要。我的代码中确实有一些处理最大行数的逻辑。我只是为了清楚起见没有在这里展示。看起来不错。既然您现在只需要迭代所有元素，那么在末尾删除
空的
元素并再次使用
转置
会更简单吗？Byron，有时候是这样的。但是，我发现数组
为空
的数据中存在缺口，然后在空部分之后有更多的数据。因此，为了确保不丢失数据，必须检查数组中的所有数据值。在遍历整个数组之后，除去
空的
值似乎比转置整个数组需要更多的工作。