Visual Basic for Applications/Charts from Arrays
Summary
editCharts can be either embedded, where they are found in association with worksheets, or can occupy sheets of their own. The code example below makes basic charts on their own sheets. Purely to test the code, there is a procedure to fetch a selection of cells from the worksheet. Clearly, this procedure is justified only for testing since there are easier ways to make charts starting from a selection of cells. Array charting is generally most useful when data is not first written to a worksheet.
The chart procedure runs from an array. The array can contain one X series, and any practical number of Y series. However, the layout of the array is strict; the first row must contain only X data. All other rows will be treated as having Y series data in them. No heading labels can be included.
If the source data has its series in columns instead of the rows required by the chart array, then the data is transposed before the charting point. A transpose procedure is included in the code.
The code can be tested as a self-contained standard module.
The VBA Code
editBecause there are too many variations of chart types to accommodate with any accuracy, only the most general properties can be considered in one procedure. As a result, the user should add any specific code to the appropriate sections.
Note that in the supporting procedures, both empty selections and insufficient selections generate errors, so a minimal error handling was added.
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