excelvbatimelineindex-match

Create Gantt Chart style timeline from data in three columns

I am trying to create a timeline based on a table 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 a snapshot.

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 use formulas to get the information in the diagram but with it being so data hungry I suspect it will either crash Excel or take three weeks to run.

Is there a VBA equivalent to:

=IFERROR(INDEX($B:$B,MATCH(G$1&$F2,$C:$C&$A:$A,0)),"")

enter image description here

Solution

  • 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

    enter image description here