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

Question

我收到了一张包含 4 个图表的 Excel 表格。图表的数据位于另一个未提供的工作簿中。

目标：我想使用 VBA 子程序从图表中提取数据。

问题：我在“类型不匹配”方面遇到了一些问题。当我尝试将 Variant 数组 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)

使用 Locals 窗口进一步检查后，我发现以下内容：

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

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

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

在这种情况下，循环遍历许多单元格很慢（我已经尝试过）。请不要使用循环，除非它是 1,000,000 个元素的秒数。

Answer 1

主要原因是内置的Transpose 函数。 Transpose 只能处理 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