copy

Thursday, 27 September 2012



Create Sparklines Automatically

This is the second project I completed in response to my VBA offer. Matthias from Stuttgart asked me if is possible to automate the creation of sparklines. First of all, what is a sparkline? Well, according to Wikipedia “A sparkline is a very small line chart, typically drawn without axes or coordinates. It presents the general shape of the variation (typically over time) in some measurement, such as temperature or stock market price, in a simple and highly condensed way.”

Sparklines are a new feature of Excel 2010 and are quite useful, since you can have a quick overview of what is going on to your data in a single cell! Matthias for example had hourly measurements and he wanted to create sparkline charts for each day, month and quarter. So, the purpose of the code below is to automate the creation of sparklines.


VBA Code

Option Explicit

Sub CreateSparklines()
    
    'This macro creates sparklines in the column next to the last column of the sheet.
    'Input data must be in the range (B2: Last Row Last Column).
    'Next to sparkline column it writes the min and max of sparkline.
    
    'By Christos Samaras
    'http://www.myengineeringworld.net
    
    'Declaring the necessary variables.
    Dim LastRow                 As Long
    Dim LastColumn              As Long
    Dim AfterLastColumnLetter   As String
    Dim myBorders()             As Variant
    Dim Item                    As Variant
    Dim i                       As Long
    Dim RowMin                  As Double
    Dim RowMax                  As Double
        
    'This array contains the names of the four edges of a border.
    myBorders = Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight)
    
    'Only office 2010 supports sparklines.
    If Application.Version = "12.0" Or _
        Application.Version = "11.0" Or _
        Application.Version = "10.0" Or _
        Application.Version = "9.0" Or _
        Application.Version = "8.0" Or _
        Application.Version = "7.0" Then
        MsgBox "Sorry, this macro cannot run properly in office prior to 2010!", _
                vbCritical, "Office Version Error"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    'Find last row and last column of data.
    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With
    
    'Here is a trick to convert the column number to letter.
    AfterLastColumnLetter = Mid(Cells(2, LastColumn + 1).Address, _
    InStr(Cells(2, LastColumn + 1).Address, "$") + 1, _
    InStr(2, Cells(2, LastColumn + 1).Address, "$") - 2)
    
    'Set the sparkline heading and format it.
    Range(AfterLastColumnLetter & 1).Select
    With Selection
        .Value = "SPARKLINE"
        With .Font
            .Name = "Arial"
            .Size = 11
            .ColorIndex = xlAutomatic
            .Bold = True
        End With
    End With
    
    'Using an array to make all borders thick.
    For Each Item In myBorders
        With Selection.Borders(Item)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
    Next Item
    
    'Make sparkline cells more visible.
    With ActiveSheet
        .Rows("2:" & LastRow).RowHeight = 33.75 '45 pixels
        .Columns(AfterLastColumnLetter).ColumnWidth = 13.57 '100 pixels
    End With
    
    'Create the sparklines.
    Range(Cells(2, LastColumn + 1), Cells(LastRow, LastColumn + 1)).Select
    Selection.SparklineGroups.Add Type:=xlSparkLine, _
    SourceData:=Range(Cells(2, 2), Cells(LastRow, LastColumn)).Address
    
    'Format the sparklines.
    With Selection.SparklineGroups.Item(1)
        .SeriesColor.Color = RGB(112, 48, 160)
        .LineWeight = 1.5
        With .Points
            .Highpoint.Visible = True
            .Highpoint.Color.Color = RGB(0, 176, 240)
            .Lowpoint.Visible = True
            .Lowpoint.Color.Color = RGB(255, 0, 0)
        End With
    End With
    
    'Format the cell borders.
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        With .Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
    End With

    'Make the external borders thick.
    For Each Item In myBorders
        With Selection.Borders(Item)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
    Next Item
    
    'Find the min and max of each sparkline and write them to the next column (left).
    'The min and max values are formatted in a way to fit to the cell height.
    'Furthermore the min and max color matches the sparkline min and max colors.
    For i = 2 To LastRow
        'Calculate the min and max of the row.
        RowMin = WorksheetFunction.Min(Range(Cells(i, 2), Cells(i, LastColumn)))
        RowMax = WorksheetFunction.Max(Range(Cells(i, 2), Cells(i, LastColumn)))
        'Write min and max in the column next to sparkline.
        With Cells(i, LastColumn + 2)
            .Value = RowMax & vbLf & vbLf & RowMin
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .Font.Size = 8
            .Font.Color = RGB(255, 0, 0)
            .Font.Bold = True
            .WrapText = True
            'Change the color of max value to fit with sparkline max color.
            .Characters(Start:=1, Length:=Len(CStr(RowMax))).Font.Color = RGB(0, 176, 240)
        End With
    Next i
   
    Cells(2, LastColumn + 1).Select
    
    Application.ScreenUpdating = True
            
End Sub


How to use it

The short video below demonstrates the sparklines that are created from daily, monthly and quarterly measurements of the previous year (2011).



Download it from here


The file can be opened only with Office 2010. Please, remember to enable macros before using it.

Did you like this post? If yes, then share it with your friends. Thank you!


Categories:


Mechanical Engineer (Ph.D. cand.), M.Sc. Cranfield University, Dipl.-Ing. Aristotle University, Thessaloniki - Greece.
Communication: e-mail, Facebook, Twitter, Google+ and Linkedin. More info