VBAmacros在Excel 2007,2010和2013中从图表中提取数据

我被发送了一张Excel表格，里面有4个图表。 图表的数据位于另一个未提供的工作簿中。

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

问题：“types不匹配”我遇到了一些麻烦。 当我尝试将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) 

进一步检查使用本地人窗口，我发现以下内容：

下面的代码工作，而上面的代码没有。

 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 

为什么没有第一个代码工作？

在这种情况下循环播放许多单元格很慢（我试过）。 请不要使用循环，除非是100万个元素的秒数。

Answer 1

主要原因是内置的Transposefunction。 Transpose只能处理2 ^ 16或更less元素的数组。

下面的代码运行良好。 它处理2 ^ 16个元素的移调function限制的问题。 它使用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