Colouring variable text within a cell / string, and merging a variable number of cells

Try the attached

Sub test()
    Dim a, i As Long, pref As String, e
    Dim rng As Range, r As Range, mtch As Object, m As Object, s As Object
    a = Cells(1).CurrentRegion.Value
    a(1, 3) = "Status / Due Date"
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If a(i, 3) = "Closed" Then
                pref = a(i, 3) & ", Completed "
            Else
                pref = IIf(a(i, 4) < Date, "Over ", "") & "Due, "
            End If
            If Not .exists(a(i, 1)) Then
                .Item(a(i, 1)) = .Count + 2
                a(.Item(a(i, 1)), 1) = a(i, 1)
                a(.Item(a(i, 1)), 2) = "1. " & a(i, 2)
                a(.Item(a(i, 1)), 3) = "1. " & pref & Format$(a(i, 4), "yyyy/m/d")
                a(.Item(a(i, 1)), 4) = 1
            Else
                a(.Item(a(i, 1)), 4) = a(.Item(a(i, 1)), 4) + 1
                a(.Item(a(i, 1)), 2) = a(.Item(a(i, 1)), 2) & vbLf & _
                a(.Item(a(i, 1)), 4) & ". " & a(i, 2)
                a(.Item(a(i, 1)), 3) = a(.Item(a(i, 1)), 3) & vbLf & _
                a(.Item(a(i, 1)), 4) & ". " & pref & Format$(a(i, 4), "yyyy/m/d")
            End If
        Next
        i = .Count
    End With
    Set rng = [g1].Resize(i + 1, 3)
    rng.Clear
    rng.Value = a
    With CreateObject("VBScript.RegExp")
        .Global = True: .MultiLine = True
        For Each r In rng.Columns(3).Cells
            For Each e In Array("Completed", "Over Due")
                .Pattern = "^(\d+).+" & e & ".+"
                If .test(r.Value) Then
                    Set mtch = .Execute(r.Value)
                    For Each m In mtch
                        .Pattern = "^" & m.submatches(0) & ".+"
                        Set s = .Execute(r(, 0).Value)(0)
                        r.Characters(m.firstindex + 1, m.Length).Font.ColorIndex = _
                        Switch(e = "Completed", 15, e = "Over Due", 3)
                        r(, 0).Characters(s.firstindex + 1, s.Length).Font.ColorIndex = _
                        Switch(e = "Completed", 15, e = "Over Due", 3)
                    Next
                End If
            Next
        Next
    End With
End Sub