从三列数据创建甘特图样式时间线

Question

我正在尝试根据每个图像的表格创建一个时间线。

我希望输出看起来像右手图，但以 5 分钟为增量，以减小列表的大小，因为这将在上午 6 点至早上 6 点运行。

大约有 10k 行数据，所以这是一个快照。

所有内容都将在同一个工作表上。

桌子
这些列将始终位于同一位置。
时间为“HH:MM”格式。
人名永远是唯一的。

输出
标题行将始终相同。
时间应以 5 分钟为增量，因此如果时间落在行时间和其上面的时间之间，则添加它是哪个玩家。
玩家应以黄色突出显示，上面的单元格为蓝色。

我使用公式来获取图表中的信息，但由于它是如此需要数据，我怀疑它要么会崩溃Excel，要么需要三周的时间才能运行。

是否有一个VBA相当于：

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

Answer 1

• 输出表分为5分钟间隔。如果两个目标彼此相邻，则可能会发生重叠。
• 重叠的玩家以红色突出显示。

微软文档：

Range.NumberFormatLocal 属性 (Excel)

范围.清除方法（Excel）

Interior.Color 属性 (Excel)

Range.Offset 属性 (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

---