Visual Basic for Applications/Charts from Arrays
Charts 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
Because 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