VBA Create Gantt Chart style timeline from data in 3 column

First post here after driving myself mad trying to find a workable solution to this. I have tried to give as much information as possible in the hopes that somebody can help please!

I am trying to create a timeline based on a table as per the image.

I want the output to look like the right hand diagram but in 5 minute increments to reduce the size of the list as this will run 6am-6am. It will be about 10k rows of data so this is just a snap shot.It will all be on the same worksheet.

The table The columns will always be in the same place. The time is "HH:MM" format. The person name will always be unique.
The output The header row will always be the same. The times should be in increments of 5 minutes so if the time falls between the row time and the time above it then add which player it is. The player should be highlighted in yellow with the cell above being blue.

I have used formulas to get the information in the diagram but with it being so data hungry i suspect it will either crash excel or take 3 weeks to run. Is there a VBA equivalent to this. =IFERROR(INDEX($B:$B,MATCH(G$1&$F2,$C:$C&$A:$A,0)),"")

enter image description here

Solution

The output table is divided into 5-minute intervals. Overlaps may occur if two goals are adjacent to each other.
Overlaps players are highlighted with red.

Microsoft documentation:

Range.NumberFormatLocal property (Excel)

Range.Clear method (Excel)

Interior.Color property (Excel)

Range.Offset property (Excel)

Option Explicit

Sub Demo()
    Dim i As Long, iCol As Long
    Dim arrData, rngData As Range, olRng As Range
    Dim arrRes, iR As Long, iM As Long, iH As Long
    Dim LastRow As Long, iOffSet As Long
    ' Init. output table
    Columns("F:F").ClearContents
    Columns("F:F").NumberFormatLocal = "hh:mm"
    Range("F3").Value = "6:00"
    Range("F4:F291").Formula = "=R[-1]C+TIMEVALUE(""0:5:0"")"
    ' load header location into Dict
    Const HEADER_START = "G2"
    Dim objDic As Object, c As Range
    Set objDic = CreateObject("scripting.dictionary")
    With Range(HEADER_START, Range(HEADER_START).End(xlToRight))
        .Offset(1).Resize(290).Clear
        For Each c In Range(HEADER_START, Range(HEADER_START).End(xlToRight)).Cells
            objDic(c.Value) = c.Column - Range(HEADER_START).Column
        Next
    End With
    ' load data into an array
    Set rngData = ActiveSheet.Range("A1").CurrentRegion
    arrData = rngData.Value
    ' loop through data
    For i = LBound(arrData) + 1 To UBound(arrData)
        iH = VBA.Hour(arrData(i, 1))
        iM = VBA.Minute(arrData(i, 1))
        ' round to x5/x0 min.
        If iM Mod 5 <> 0 Then
            iM = iM + (5 - iM Mod 5)
            If iM = 60 Then
                iH = iH + 1
                iM = 0
            End If
        End If
        ' before 6am in the next day
        If iH < 6 Then iH = iH + 24
        iOffSet = ((iH - 6) * 60 + iM) / 5
        If objDic.exists(arrData(i, 3)) Then
            iCol = objDic(arrData(i, 3))
            ' populate output table
            With Range(HEADER_START).Offset(1, iCol)
                CheckOverlap olRng, .Offset(iOffSet)
                .Offset(iOffSet).Value = arrData(i, 2)
                .Offset(iOffSet).Interior.Color = vbYellow
                .Offset(iOffSet - 1).Interior.Color = vbCyan
            End With
        Else
            MsgBox "Missing team in output header: " & arrData(i, 3)
        End If
    Next i
    If Not olRng Is Nothing Then
        olRng.Interior.Color = vbRed
    End If
End Sub

Sub CheckOverlap(ByRef allRng As Range, cRng As Range)
    Dim c As Range
    For Each c In cRng.Offset(-1).Resize(3)
        If Len(c.Value) > 0 Then
            If allRng Is Nothing Then
                Set allRng = Application.Union(c, cRng)
            Else
                Set allRng = Application.Union(allRng, c, cRng)
            End If
        End If
    Next
End Sub