VBA 创建带有日/小时/分钟时间戳的甘特图

Question

我正在尝试从开始时间戳和结束时间戳列创建甘特图。

到目前为止，我有将日期创建为具有零小时和分钟时间戳的列的代码：

您会注意到单元格中有几行 Start_Timestamp 日行值与列名称的日期匹配。这些实际上是压缩的矩形，但我想做的是将这些矩形扩展为从 Start_Timestamp 的小时和分钟开始，到 End Timestamp 的小时和分钟结束。

这是我想做的事情的近似值（我手动完成）：

这是创建我的起始日历的代码：

Sub Create_Calendar()
Sheets("Gantt").UsedRange.Delete
Sheets("Triece_Calendar").Columns("A:F").Copy Destination:=Sheets("Gantt").Columns("A:F")
 Dim ws As Worksheet
    Set ws = Worksheets("Gantt")

    With ws.Range(ws.Cells(1, 1), ws.UsedRange) 'Adjust for empty rows/columns
        'Column G is Column 7
        .Range(.Range("G2"), .Cells(.Rows.Count, 7)).Formula = "=INT(B2)+MOD(C2,1)"
        .Columns("G").Calculate 'Make sure the values have calculated
        .Columns("G").NumberFormat = "yyyy/mm/dd hh:mm;@" 'Display in your format
        .Range("G1").Value = "Start_Timestamp"
        .Range(.Range("H2"), .Cells(.Rows.Count, 8)).Formula = "=INT(D2)+MOD(E2,1)"
        .Columns("H").Calculate 'Make sure the values have calculated
        .Columns("H").NumberFormat = "yyyy/mm/dd hh:mm;@" 'Display in your format
        .Range("H1").Value = "End_Timestamp"
        .Range("B:E").EntireColumn.Hidden = True
    End With
    Min_Date = Application.WorksheetFunction.Min(Columns("G"))
    Max_Date = Application.WorksheetFunction.Max(Columns("H"))
    NextDate = Min_Date
    Range("I1").Select
     
    'selection of columns within one row
    Do Until NextDate > Max_Date
        Selection.NumberFormat = "yyyy/mm/dd hh:mm;@"
        ActiveCell.Value = NextDate - TimeSerial(Hour(NextDate), Minute(NextDate), 0)
        ActiveCell.Offset(0, 1).Select
        NextDate = NextDate + 1
    Loop
    ActiveCell.Value = Max_Date + 1
    ActiveCell.NumberFormat = "yyyy/mm/dd hh:mm;@"
    ActiveCell.Value = ActiveCell.Value - TimeSerial(Hour(Max_Date), Minute(Max_Date), 0)
End Sub

这是我目前用来放置形状的代码：

    Sub Create_Gantt()
    ActiveSheet.UsedRange.Delete
    Create_Calendar
    Dim X As Integer
    Dim dTotWidth As Double, dDayWidth As Double, dLeftStart As Double
    Dim dLeft As Double, dtop As Double, dWidth As Double, dHeight As Double
    Dim dtStart As Date, dtEnd As Date, sName As String, sColor As String
    Dim myShape As Shape, dycwidth As Double, dRight As Double
    Dim Lastrow As Integer

    dLeftStart = Range("I2").Left
    X = 1
    
    'Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    'With Range("G2:G" & Lastrow)
        '.Cells(Application.Match(WorksheetFunction.Min(.Cells), .Cells, 0), 1).Select
    'End With
    Range("G2").Select
    
   
    Do Until ActiveCell.Value = ""
        dDayWidth = DateDiff("d", ActiveCell.Offset(0, 1).Value, ActiveCell.Value)
    'Baseline
        ' calculate top ...
        dtop = ActiveCell.Top + 3
    
    'calculate Left
        p = 9
        Do Until Month(Cells(1, p)) = Month(ActiveCell.Value) And _
        Year(Cells(1, p)) = Year(ActiveCell.Value) And _
        Day(Cells(1, p)) = Day(ActiveCell.Value)
        
        
        p = p + 1
        Loop
        dLeft = Cells(1, p).Left
        dLeft = dLeft + (dDayWidth * DateDiff("d", Cells(1, p), ActiveCell.Value))
    
        
        p = 9
        'calculate width ...
        Do Until Month(Cells(1, p)) = Month(ActiveCell.Offset(0, 1).Value) And _
        Year(Cells(1, p)) = Year(ActiveCell.Offset(0, 1).Value) And _
        Day(Cells(1, p)) = Day(ActiveCell.Offset(0, 1).Value)
        
        
        
        p = p + 1
        Loop
        dRight = Cells(1, p).Left
        dRight = dRight + (dDayWidth * DateDiff("d", Cells(1, p), ActiveCell.Offset(0, 1).Value))
        dWidth = dRight - dLeft

        sName = "Scheduled" & X
        Call DynamicBox(dLeft, dtop, dWidth, 11, sName)
        
    ActiveCell.Offset(1, 0).Select: X = X + 1
    Loop
    
End Sub

Sub DynamicBox(dLeft As Double, dtop As Double, dWidth As Double, dHeight As Double, sName As String)
Dim X As Double
 
    'reference to the 4 numbers left,top,width,height
ActiveSheet.Shapes.AddShape _
 (msoShapeFlowchartProcess, dLeft, dtop, dWidth, dHeight).Select
 If InStr(sName, "Scheduled") > 0 Then
 Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 255, 0)
 Else
 Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 0, 255)
 End If
 
 Selection.ShapeRange.Fill.Solid
 Selection.ShapeRange.Fill.Visible = msoTrue
 Selection.Name = sName

End Sub

任何关于如何修改此代码以正确调整大小和放置形状的输入将不胜感激。

Answer 1

计算同一日期值之间的天数：

DateDiff("d", Cells(1, p), ActiveCell.Value)

将始终返回零。所以，试着数分钟：

dRight = dRight + (dDayWidth * DateDiff("n", Cells(1, p), ActiveCell.Offset(0, 1).Value) / 3600)

此外，您真的应该阅读使用Range对象来代替笨拙和缓慢的Selection和ActiveCell。