Visual Basic for Applications/Charts from Arrays

SummaryEdit

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 CodeEdit

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