從陣列建立 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