Question

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

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

问题：我遇到“类型不匹配”的问题。当我尝试将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窗口进一步检查后，我发现以下内容： enter image description here

以下代码无效。

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

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

1 个答案: