Conditonal formatting to show the percentage split of a summed cell based on the numbers used in other cells

Question

I hope I can explain this well enough.

I have a column (D) which is showing me how many subjects a pupil sat for their GCSEs. This is made up of straight GCSE subjects (F) and BTEC subjects (H).

I would like a visual representation of this make-up of subjects shown in column D.

I.e. a pupil sat 8 subjects (value of 8 in column D). They have sat 4 straight GCSE subjects (value of 4 in column F) and 4 BTEC subjects (also value of 4 in column H). In column D I would like it to be coloured so that it shows half the cell in one colour and the other half in a different colour (not a gradient). Similarly, if a pupil sat 2 straight GCSE subjects and 6 BTEC subjects, the cell in column D should be formatted according to the percentage split.

I had thought I could do it using 2 different data bar rules on the cells, one filling left-right and the other right-left but that did not work.

Hoping there is a simple solution that I can't find.

(A) Name	(B) Form Class	(C) Attendance	(D) Total Subs	(E) A*-C	(F) Straight	(G) <- No.	(H) BTEC	(I) <- No.
John	12B4	95	8	6	4	2	4	4

Answer 1

Built-in formats may not support this. Code works around it but shapes cover cells in column D, preventing clicking selection.

Sub demo()
    Dim lastRow As Long
    Dim c As Range, sRatio As Single
    Dim oShp1, oShp2
    ActiveSheet.DrawingObjects.Delete
    lastRow = Cells(Rows.Count, "D").End(xlUp).Row
    For i = 2 To lastRow
        Set c = Cells(i, "D")
        sRatio = Cells(i, "F") / c.Value
        ' Add the first rect
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
            c.Left, c.Top, c.Width * sRatio, c.Height).Select
        ' Change rect format
        With Selection.ShapeRange.Fill
            .Visible = msoTrue
            .ForeColor.RGB = RGB(0, 255, 0) ' fill in color
            .Transparency = 0.5
            .Solid
            .Parent.Line.Weight = 0.1 ' boarder line
        End With
        Selection.Copy
        ActiveCell.Select
        ' Add the second rect
        ActiveSheet.Paste
        With Selection
            .Left = c.Left + c.Width * sRatio
            .Top = c.Top
            .Width = c.Width * (1 - sRatio)
            .ShapeRange.Fill.ForeColor.RGB = RGB(0, 0, 255)
        End With
    Next
    ActiveCell.Select
End Sub