從 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 個元素的 Transpose 函數限制問題。 它使用 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