Excel VBA矩形框定位偏移问题及代码优化咨询

尝试用Excel VBA制作默认日程表，按固定间隔放置矩形块，但矩形框离第一列越远，偏离预期位置的程度越大。同时，当A阶段起始日期为2024年1月15日时，预期结束日期为3月9日（8周），但实际出现偏差。

相关配置与原代码如下：

• Home工作表B3：起始日期2024/01/01
• Home工作表B4：结束日期2027/12/31
• Home工作表B5：总天数（B4-B3）
• Home工作表G11：第一阶段起始日期2024/01/15
• 活动工作表第6行：日期行；第7行：日程行
• rg：活动工作表单元格区域("B7")

Public Function Default_Project_Milestones_Schedule_add(rg)
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim days As Integer
Dim thisday As Date
Dim shp As Shape
Dim shp2 As Shape
Dim w As Double
Dim interval As Double
Const we1 = 6 'Sat
Const we2 = 7 'Sun
    

days = ThisWorkbook.Sheets("Home").Range("B5").Value
For i = 1 To days
    thisday = DateAdd("d", (i - 1), ThisWorkbook.Sheets("Home").Range("B3").Value)
    If Weekday(thisday, vbMonday) = we1 Or Weekday(thisday, vbMonday) = we2 Then
        j = j + 1
    End If
    If ThisWorkbook.Sheets("Home").Range("G11") = thisday Then
        Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1, 1, 1, 45)
        k = rg.Offset(0, i).Top
        With shp
            .Left = rg.Offset(0, i - j).Left
            .Top = k + shp.Height / 2.5
            .Width = Range(rg.Offset(0, i - j), rg.Offset(0, i - j + (8 * 5))).Width 'Phase A considered: 8wks
            .TextFrame.Characters.Text = "A"
            .TextFrame.Characters.Font.Color = 1
            .TextFrame.Characters.Font.Size = 18
            .TextFrame.HorizontalAlignment = xlHAlignCenter
            .TextFrame.VerticalAlignment = xlVAlignCenter
        End With
        Set shp2 = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1, 1, 1, 45)
        w = shp.Width
        interval = Range(rg.Offset(0, i - j + (8 * 5)), rg.Offset(0, i - j + (8 * 5) + (5 * 5))).Width 'Interval between phases considered: 5wks
        With shp2
            .Left = w + interval + rg.Offset(0, i - j).Left
            .Top = k + shp2.Height / 2.5
            .Width = Range(rg.Offset(0, i - j + (8 * 5) + (5 * 5)), rg.Offset(0, i - j + (8 * 5) + (5 * 5) + (6 * 5))).Width 'Phase B considered: 6wks
            .TextFrame.Characters.Text = "B"
            .TextFrame.Characters.Font.Color = 1
            .TextFrame.Characters.Font.Size = 18
            .TextFrame.HorizontalAlignment = xlHAlignCenter
            .TextFrame.VerticalAlignment = xlVAlignCenter
        End With
    End If
Next i

End Function

1. 列偏移逻辑错误
   你错误地将「累计工作日数量」（i-j）当作列偏移量使用。活动工作表的日期列是按所有日期（含周末）连续排列的，从起始日B3开始的第N天，对应的列偏移量应为N-1（即phaseStartDate - startDate），而非扣除周末后的工作日数。随着日期后移，累计周末数逐渐增加，i-j与实际列偏移量的差距越来越大，最终导致矩形位置偏移愈发严重。

2. 阶段范围计算错误
   你用8*5（40个工作日）来确定阶段A的列范围，但实际需要的是8周的时间跨度。如果按日历周计算，从2024/1/15开始8周后的日期是2024/3/11；如果按40个工作日计算，结束日期应为WorksheetFunction.WorkDay(#1/15/2024#, 40)=2024/3/13。你预期的3/9与实际偏差，本质是固定列数偏移无法匹配包含周末的日期列布局。

' 封装形状公共格式设置，减少重复代码
Sub SetShapeFormat(shp As Shape, displayText As String)
    With shp
        .Height = 45
        .TextFrame.Characters.Text = displayText
        .TextFrame.Characters.Font.Color = vbBlack
        .TextFrame.Characters.Font.Size = 18
        .TextFrame.HorizontalAlignment = xlHAlignCenter
        .TextFrame.VerticalAlignment = xlVAlignCenter
    End With
End Sub

Public Function Default_Project_Milestones_Schedule_add(rg As Range)
    Dim wsHome As Worksheet, wsActivity As Worksheet
    Dim startDate As Date, phaseStartDate As Date
    Dim phaseAEnd As Date, intervalEnd As Date, phaseBEnd As Date
    Dim startColOffset As Long, phaseAEndOffset As Long
    Dim intervalOffset As Long, phaseBEndOffset As Long
    Dim topPosition As Double
    Dim shpPhaseA As Shape, shpPhaseB As Shape
    
    ' 明确指定工作表，避免ActiveSheet的不确定性
    Set wsHome = ThisWorkbook.Sheets("Home")
    Set wsActivity = rg.Parent
    
    ' 提前读取关键日期，减少工作表访问次数
    startDate = wsHome.Range("B3").Value
    phaseStartDate = wsHome.Range("G11").Value
    
    ' 计算各阶段结束日期（可根据需求切换日历周/工作日模式）
    ' 模式1：按日历周计算
    phaseAEnd = DateAdd("ww", 8, phaseStartDate) ' 8周后
    intervalEnd = DateAdd("ww", 5, phaseAEnd)   ' 间隔5周
    phaseBEnd = DateAdd("ww", 6, intervalEnd)   ' 阶段B6周
    
    ' 模式2：按工作日计算（取消注释即可切换）
    ' phaseAEnd = WorksheetFunction.WorkDay(phaseStartDate, 40) ' 40个工作日
    ' intervalEnd = WorksheetFunction.WorkDay(phaseAEnd, 25)   ' 25个工作日间隔
    ' phaseBEnd = WorksheetFunction.WorkDay(intervalEnd, 30)   ' 30个工作日阶段B
    
    ' 计算各日期对应的列偏移量（相对于rg单元格）
    startColOffset = phaseStartDate - startDate
    phaseAEndOffset = phaseAEnd - startDate
    intervalOffset = intervalEnd - startDate
    phaseBEndOffset = phaseBEnd - startDate
    
    ' 计算形状垂直位置
    topPosition = rg.Offset(0, startColOffset).Top + 45 / 2.5
    
    ' 添加阶段A矩形
    Set shpPhaseA = wsActivity.Shapes.AddShape(msoShapeRectangle, _
        rg.Offset(0, startColOffset).Left, _
        topPosition, _
        wsActivity.Range(rg.Offset(0, startColOffset), rg.Offset(0, phaseAEndOffset)).Width, _
        45)
    Call SetShapeFormat(shpPhaseA, "A")
    
    ' 添加阶段B矩形
    Set shpPhaseB = wsActivity.Shapes.AddShape(msoShapeRectangle, _
        rg.Offset(0, intervalOffset).Left, _
        topPosition, _
        wsActivity.Range(rg.Offset(0, intervalOffset), rg.Offset(0, phaseBEndOffset)).Width, _
        45)
    Call SetShapeFormat(shpPhaseB, "B")
    
End Function

• 消除ActiveSheet依赖：通过rg.Parent获取活动工作表，明确指定wsHome，避免工作表切换时的错误。
• 减少工作表交互：提前读取所有关键日期，避免循环中重复访问单元格，提升运行效率。
• 模块化格式设置：将形状的公共格式封装为子过程，减少重复代码，便于后续修改维护。
• 精准列偏移计算：直接通过日期差计算列偏移量，确保矩形与日期列完全对应，解决位置偏移问题。
• 灵活的阶段计算：提供两种阶段日期计算模式（日历周/工作日），可根据需求快速切换。

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