Adding click-to-update "Traffic lights" to a dashboard

Traffic light dashboards

I sometimes need to create dashboards that represent the status of a number of elements. Perhaps it could represent some important information about key customers as below:





This looks nice, but every time you need to update the status of an element, you need to fiddle about with the colour of the shape. The code below avoids this by linking a click on a shape to a macro that cycles through the colours. In the example below I have 4 colours: red, amber, green and white, which represents undefined.

Create a single Oval shape and assign the macro below to it:

Sub RotateRAGColour()
Const cWhite = 16777215
Const cGreen = 5287936
Const cAmber = 49407
Const cRed = 192
Dim shp As Shape

    Set shp = ActiveSheet.Shapes(Application.Caller)
    
    Select Case shp.Fill.ForeColor.RGB
        Case cWhite
            shp.Fill.ForeColor.RGB = cGreen
        Case cRed:
            shp.Fill.ForeColor.RGB = cWhite
        Case cAmber:
            shp.Fill.ForeColor.RGB = cRed
        Case cGreen:
            shp.Fill.ForeColor.RGB = cAmber
        
    End Select
End Sub

This cycles through the colours White-Green-Orange-Red. Copy the shape as many times as you need to create the dashboard. The following macro centres the shapes in the cell they are in:

Sub CentreTrafficLights()
Dim shp As Shape

    For Each shp In ActiveSheet.Shapes
        If shp.AutoShapeType = msoShapeOval Then
            Set rng = shp.TopLeftCell
            shp.Left = rng.Left + (rng.Width - shp.Width) / 2
            shp.Top = rng.Top + (rng.Height - shp.Height) / 2
        End If
    Next
End Sub