如何修改VBA代码实现带时分秒时间戳的甘特图形状精准定位

问题 #

我正尝试通过Start_Timestamp列与End_Timestamp列创建甘特图。目前已有可生成仅含日期（时分秒为零）列的代码，当前生成的形状为压缩矩形，希望修改代码使矩形能依据时间戳的时分秒准确起始和结束。以下是现有创建日历及放置形状的VBA代码，恳请提供修改建议以实现正确的形状尺寸与位置设置。

关键修改说明 #

• 日历生成逻辑简化：确保每列代表完整一天，方便计算单天宽度基准
• 精确时间比例换算：通过时间戳的时分秒占全天的比例，计算形状在列内的偏移和宽度
• 修复原代码中日期差计算的参数顺序错误
• 减少不必要的Select操作，提升代码稳定性

修改后的创建日历代码 #

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)
        ' 合并日期与时间生成完整时间戳
        .Range(.Range("G2"), .Cells(.Rows.Count, 7)).Formula = "=INT(B2)+MOD(C2,1)"
        .Columns("G").Calculate
        .Columns("G").NumberFormat = "yyyy/mm/dd hh:mm;@"
        .Range("G1").Value = "Start_Timestamp"
        
        .Range(.Range("H2"), .Cells(.Rows.Count, 8)).Formula = "=INT(D2)+MOD(E2,1)"
        .Columns("H").Calculate
        .Columns("H").NumberFormat = "yyyy/mm/dd hh:mm;@"
        .Range("H1").Value = "End_Timestamp"
        
        .Range("B:E").EntireColumn.Hidden = True
    End With
    
    Dim Min_Date As Date, Max_Date As Date, NextDate As Date
    Min_Date = Application.WorksheetFunction.Min(ws.Columns("G"))
    Max_Date = Application.WorksheetFunction.Max(ws.Columns("H"))
    NextDate = DateValue(Min_Date) ' 取纯日期作为起始
    
    ws.Range("I1").Select
    ' 生成每天的日期列（时分秒为0）
    Do Until NextDate > DateValue(Max_Date)
        ActiveCell.NumberFormat = "yyyy/mm/dd"
        ActiveCell.Value = NextDate
        ActiveCell.Offset(0, 1).Select
        NextDate = NextDate + 1
    Loop
    ' 添加最后一列用于边界计算
    ActiveCell.Value = NextDate
    ActiveCell.NumberFormat = "yyyy/mm/dd"
End Sub

修改后的放置形状代码 #

Sub Create_Gantt()
    ActiveSheet.UsedRange.Delete
    Create_Calendar
    
    Dim X As Integer
    Dim dDayWidth 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
    Dim p As Integer
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    ' 获取单天列的宽度
    dDayWidth = ws.Cells(1, 9).Width
    X = 1
    
    ws.Range("G2").Select
    Do Until ActiveCell.Value = ""
        dtStart = ActiveCell.Value
        dtEnd = ActiveCell.Offset(0, 1).Value
        dtop = ActiveCell.Top + 3
        dHeight = 11
        
        ' 计算形状左侧位置：找到起始日期列 + 当天内的时间偏移
        p = 9
        Do Until ws.Cells(1, p).Value = DateValue(dtStart)
            p = p + 1
        Loop
        Dim startTimeRatio As Double
        startTimeRatio = (dtStart - DateValue(dtStart)) / 1 ' 当天时间占全天的比例
        dLeft = ws.Cells(1, p).Left + (startTimeRatio * dDayWidth)
        
        ' 计算形状右侧位置：找到结束日期列 + 当天内的时间偏移
        p = 9
        Do Until ws.Cells(1, p).Value = DateValue(dtEnd)
            p = p + 1
        Loop
        Dim endTimeRatio As Double
        endTimeRatio = (dtEnd - DateValue(dtEnd)) / 1
        Dim dRight As Double
        dRight = ws.Cells(1, p).Left + (endTimeRatio * dDayWidth)
        
        ' 计算形状宽度
        dWidth = dRight - dLeft
        
        ' 创建形状
        sName = "Scheduled" & X
        Call DynamicBox(dLeft, dtop, dWidth, dHeight, 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 shp As Shape
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeFlowchartProcess, dLeft, dtop, dWidth, dHeight)
    
    If InStr(sName, "Scheduled") > 0 Then
        shp.Fill.ForeColor.RGB = RGB(0, 255, 0)
    Else
        shp.Fill.ForeColor.RGB = RGB(0, 0, 255)
    End If
    
    shp.Fill.Solid
    shp.Fill.Visible = msoTrue
    shp.Name = sName
End Sub

内容的提问来源于stack exchange，提问作者Alex Triece