从数组创建 VBA 图表
图表可以嵌入在工作表中，也可以单独占用一个工作表。下面的代码示例演示了如何在单独的工作表上创建基本图表。为了测试代码，有一个过程可以从工作表中获取选定的单元格。显然，此过程仅用于测试，因为从单元格选中区域创建图表有更简单的方法。数组图表通常在数据未首先写入工作表时最为有用。
图表过程从一个数组运行。该数组可以包含一个 X 系列和任意数量的 Y 系列。但是，数组的布局很严格；第一行只能包含 X 数据。所有其他行将被视为包含 Y 系列数据。不能包含标题标签。
如果源数据将系列放在列中，而不是图表数组所需的行列中，则在图表点之前对数据进行转置。代码中包含一个转置过程。
该代码可以作为独立的标准模块进行测试。
由于图表类型变化太多，无法在任何一个过程中准确地容纳所有类型，因此只能在单个过程中考虑最通用的属性。因此，用户应该在适当的部分添加任何特定代码。
请注意，在支持过程中，空选择和选择不足都会产生错误，因此添加了最小的错误处理。
Option Explicit
Sub ChartFromSelection()
'select a block of cells to chart - then run;
'either; top row X data, and all other rows Y series, or
'first column X data, and all columns Y series;
'set boolean variable bSeriesInColumns to identify which:
'Do not include heading labels in the selection.
Dim vA As Variant, bOK1 As Boolean, bOK2 As Boolean
Dim bTranspose As Boolean, bSeriesInColumns As Boolean
'avoid errors for 'no selection'
On Error GoTo ERR_HANDLER
'set for series in rows (True), or in columns (False)
bSeriesInColumns = False
'load selection into array
LoadArrSelectedRange vA, bSeriesInColumns
'make specified chart type
ChartFromArray vA, xlLine
'advise complete
MsgBox "Chart done!"
ActiveChart.ChartArea.Activate
Exit Sub
ERR_HANDLER:
Select Case Err.Number
Case 13 'no selection made
Err.Clear
MsgBox "Make a 2D selection of cells"
Exit Sub
Case Else
Resume Next
End Select
End Sub
Public Function LoadArrSelectedRange(vR As Variant, Optional bTranspose As Boolean = False) As Boolean
'gets the current selection of cells - at least 2 cols and 2 rows, ie, 2 x 2
'and returns data array in vR
'if bTranspose=True then selection is transposed before loading array
'before array storage - otherwise as found
Dim vA As Variant, rng As Range
Dim sht As Worksheet, vT As Variant
Dim r As Long, c As Long
Dim lb1, ub1, lb2, ub2
Dim nSR As Long, nSC As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
'make sure a range is selected
If TypeName(Selection) <> "Range" Then Exit Function
'find bounds of selection
With Application.Selection
nSR = .Rows.Count
nSC = .Columns.Count
End With
'check that enough data is selected
If nSC < 2 Or nSR < 2 Then
MsgBox "No useful selection was found." & vbCrLf & _
"Needs at least two rows and two columns" & vbCrLf & _
"for array 2D loading."
Exit Function
End If
'dimension work array
ReDim vA(1 To nSR, 1 To nSC)
'get range of current selection
Set rng = Application.Selection
'pass range of cells to array
vA = rng
'output transposed or as found
If bTranspose = True Then
TransposeArr2D vA, vT
vR = vT
Else
vR = vA
End If
'collapse selection to top left
sht.Cells(1, 1).Select
'transfers
LoadArrSelectedRange = True
End Function
Function ChartFromArray(ByVal vA As Variant, Optional vChartType As Variant = xlLine) As Boolean
'assumes multi series are in array ROWS
'if data in columns then transpose it before call
'at this point vA must have X values in first row
'and all other rows assumed to be Y series
'only data - no label columns
'Chart type notes
'================================
'xlArea,
'xlBarClustered
'xlLine, xlLineMarkers
'xlXYScatter, xlXYScatterLines
'xlPie, xlPieExploded
'xlRadar, xlRadarMarkers
'xlSurface, xlSurfaceTopView
'see link in ChartType help page
'for full list of chart types
'================================
Dim lb1 As Long, ub1 As Long, lb2 As Long, ub2 As Long
Dim X As Variant, Y As Variant, oChrt As Chart
Dim n As Long, m As Long, S As Series, bTrimAxes As Boolean
Dim sT As String, sX As String, sY As String
'set axes labels
sT = "Top Label for Chart Here"
sX = "X-Axis Label Here"
sY = "Y-Axis Label Here"
'set boolean to True to enable axes trimming code block
bTrimAxes = False
'get bounds of array
lb1 = LBound(vA, 1): ub1 = UBound(vA, 1)
lb2 = LBound(vA, 2): ub2 = UBound(vA, 2)
ReDim X(lb2 To ub2) '1 to 11 data
ReDim Y(lb2 To ub2) '1 to 11 data
'make a chart
Set oChrt = Charts.Add
'use parameter chart type
oChrt.ChartType = vChartType
'load the single X series
For n = lb2 To ub2
X(n) = vA(lb1, n)
Next n
'remove unwanted series
With oChrt
Do Until .SeriesCollection.Count = 0
.SeriesCollection(1).Delete
Loop
End With
'add the intended series
For m = 2 To ub1
'load one Y series at a time
For n = lb2 To ub2
Y(n) = vA(m, n)
Next n
'make new series object
Set S = ActiveChart.SeriesCollection.NewSeries
'transfer series individually
With S
.XValues = X
.Values = Y
.Name = "Series names"
End With
Next m
'APPLY ALL OTHER CHART PROPERTIES HERE
On Error Resume Next 'avoid display exceptions
With oChrt
'CHART-SPECIFIC PROPERTIES GO HERE
Select Case .ChartType
Case xlXYScatter
Case xlLine
Case xlPie
Case xlRadar
Case xlSurface
End Select
'GENERAL CHART PROPERTIES GO HERE
'labels for the axes
.HasTitle = True
.ChartTitle.Text = sT 'chart title
.SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis) 'X
.Axes(xlCategory).AxisTitle.Text = sX 'X
.SetElement (msoElementPrimaryValueAxisTitleRotated) 'Y
.Axes(xlValue).AxisTitle.Text = sY 'Y
.Legend.Delete
If bTrimAxes = True Then
'X Axis limits and such- set as required
.Axes(xlCategory).Select
.Axes(xlCategory).MinimumScale = 0
.Axes(xlCategory).MaximumScale = 1000
.Axes(xlCategory).MajorUnit = 500
.Axes(xlCategory).MinorUnit = 100
Selection.TickLabelPosition = xlLow
'Y Axis limits and such- set as required
.Axes(xlValue).Select
.Axes(xlValue).MinimumScale = -0.2
.Axes(xlValue).MaximumScale = 1.2
.Axes(xlValue).MajorUnit = 0.1
.Axes(xlValue).MinorUnit = 0.05
End If
End With
On Error GoTo 0
oChrt.ChartArea.Select
Set oChrt = Nothing
Set S = Nothing
ChartFromArray = True
End Function
Function TransposeArr2D(vA As Variant, Optional vR As Variant) As Boolean
'---------------------------------------------------------------------------------
' Procedure : Transpose2DArr
' Purpose : Transposes a 2D array; rows become columns, columns become rows
' Specifically, (r,c) is moved to (c,r) in every case.
' Options include, returned in-place with the source changed, or
' if vR is supplied, returned in that instead, with the source intact.
'---------------------------------------------------------------------------------
Dim vW As Variant
Dim loR As Long, hiR As Long, loC As Long, hiC As Long
Dim r As Long, c As Long, bWasMissing As Boolean
'find whether optional vR was initially missing
bWasMissing = IsMissing(vR)
If Not bWasMissing Then Set vR = Nothing
'use a work array
vW = vA
'find bounds of vW data input work array
loR = LBound(vW, 1): hiR = UBound(vW, 1)
loC = LBound(vW, 2): hiC = UBound(vW, 2)
'set vR dimensions transposed
'Erase vR 'there must be an array in the variant to erase
ReDim vR(loC To hiC, loR To hiR)
'transfer data
For r = loR To hiR
For c = loC To hiC
'transpose vW into vR
vR(c, r) = vW(r, c)
Next c
Next r
'find bounds of vW data input work array
' loR = LBound(vR, 1): hiR = UBound(vR, 2)
' loC = LBound(vR, 2): hiC = UBound(vR, 2)
TRANSFERS:
'decide whether to return in vA or vR
If Not bWasMissing Then
'vR was the intended return array
'so leave vR as it is
Else:
'vR is not intended return array
'so reload vA with vR
vA = vR
End If
'return success for function
TransposeArr2D = True
End Function
Sub LoadArrayTestData()
'loads an array with sample number data
'first row values of x 1 to 100
'next three rows y series
Dim nNS As Long, f1 As Single
Dim f2 As Single, f3 As Single
Dim vS As Variant, vR As Variant, n As Long
'dimension work array
nNS = 50
ReDim vS(1 To 4, 1 To nNS)
'make function loop
For n = 1 To nNS
f1 = (n ^ 1.37 - 5 * n + 1.5) / -40
On Error Resume Next
f2 = Sin(n / 3) / (n / 3)
f3 = 0.015 * n + 0.25
vS(1, n) = n 'X
vS(2, n) = f1 'Y1
vS(3, n) = f2 'Y2
vS(4, n) = f3 'Y3
Next n
ChartFromArray vS, xlLine
End Sub
Sub DeleteAllCharts6()
'run this to delete all ThisWorkbook charts
Dim oC
Application.DisplayAlerts = False
For Each oC In ThisWorkbook.Charts
oC.Delete
Next oC
Application.DisplayAlerts = True
End Sub