![](/img/trans.png)
[英]VBA to change data label in a chart - Compatibility btw Excel 2013 and 2010
[英]VBA Macro to extract data from a chart in Excel 2007, 2010, and 2013
我收到了一张带有 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 个元素的秒数。
主要原因是内置的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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.