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

Question

在试图找到一个可行的解决方案让自己发疯之后，在这里发表了第一篇文章。我已尽力提供尽可能多的信息，希望有人能提供帮助！

我正在尝试根据图像创建基于表格的时间线。

我希望输出看起来像右手图，但以 5 分钟为增量，以减少列表的大小，因为这将在上午 6 点至早上 6 点运行。这将是大约 10k 行数据，所以这只是一个快照。它将全部位于同一个工作表上。

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

• 输出 标题行将始终相同。 时间应以 5 分钟为增量，因此如果时间介于行时间和其上方的时间之间，则添加该玩家的身份。 玩家应以黄色突出显示，上面的单元格为蓝色。

我已经使用公式来获取图表中的信息，但由于它是如此需要数据，我怀疑它要么会使 excel 崩溃，要么需要 3 周的时间才能运行。是否有与此等效的 VBA？ =IFERROR(INDEX($B:$B,MATCH(G$1&$F2,$C:$C&$A:$A,0)),"")

Answer 1

• 输出表分为5分钟间隔。如果两个目标彼此相邻，则可能会发生重叠。

Sub Demo()
    Dim i As Long, iCol As Long
    Dim arrData, rngData 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:F290").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
        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)
                .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
End Sub