Excel VBA任务日期填充异常：单日工时超7小时时日期计算错误

需求 #

• 根据任务预估工时填充起止日期，每个工作日总工时不得超过7小时
• 在D2单元格输入起始日期后，宏自动填充下方单元格的起止日期

问题 #

当前宏代码在处理单日预估工时超过7小时的情况时，计算出的起止日期存在错误。

现有代码 #

工作表代码 #

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("D2")) Is Nothing Then
        Application.EnableEvents = False
        Call ThisWorkbook.ProjectMgmt(Target)
        Application.EnableEvents = True
    End If
End Sub

ThisWorkbook代码 #

Sub ProjectMgmt(Target As Range)

Dim stDate, enDate As Date, sTime, eTime, tTime As Long
tTime = 7

Target.Select
stDate = ActiveCell.Value

eTime = ActiveCell.Offset(0, -1).Value

Do
    If eTime < tTime Then
        ActiveCell.Value = stDate
        ActiveCell.Offset(0, 1).Value = stDate
    ElseIf eTime = tTime Then
        ActiveCell.Value = stDate
        ActiveCell.Offset(0, 1).Value = stDate
        ' need to zero the time value
        eTime = 0
        
        stDate = Application.WorksheetFunction.WorkDay_Intl(stDate, 1, 1, Worksheets("HolidayList").Range("B3:B16"))
        
    ElseIf eTime > tTime Then
        ActiveCell.Value = stDate
        ' need to check time for add end date
        stDate = Application.WorksheetFunction.WorkDay_Intl(stDate, 1, 1, Worksheets("HolidayList").Range("B3:B16"))
        ActiveCell.Offset(0, 1).Value = stDate
        eTime = eTime - tTime
    'Else
    '    MsgBox "that theriyalaye moment"
    End If
    ActiveCell.Offset(1, 0).Select
    eTime = eTime + ActiveCell.Offset(0, -1).Value

Loop Until Range("C" & ActiveCell.Row).Value = ""

End Sub

问题分析 #

原代码在处理eTime > tTime（工时超7小时）的逻辑存在两处核心错误：

1. 错误地将当前行的结束日期设为下一个工作日，实际当天应消耗满7小时，结束日期仍为当天
2. 依赖Select和ActiveCell操作单元格，代码稳定性差，容易因选中状态变化出现异常

修复后的代码 #

修改后的ThisWorkbook代码 #

Sub ProjectMgmt(Target As Range)
    Dim stDate As Date, tTime As Long
    Dim eTime As Double ' 用Double支持非整数工时，避免溢出
    Dim currentRow As Long
    Dim holidayRange As Range
    
    tTime = 7
    Set holidayRange = Worksheets("HolidayList").Range("B3:B16")
    currentRow = Target.Row
    stDate = Target.Value
    eTime = Cells(currentRow, "C").Value ' 直接引用单元格，避免ActiveCell依赖
    
    ' 清空当前行以下的D、E列旧数据
    Range("D" & currentRow + 1 & ":E" & Cells(Rows.Count, "C").End(xlUp).Row).ClearContents
    
    Do While Cells(currentRow, "C").Value <> ""
        If eTime <= tTime Then
            ' 工时≤7小时，起止日期均为当前工作日
            Cells(currentRow, "D").Value = stDate
            Cells(currentRow, "E").Value = stDate
            eTime = 0 ' 剩余工时清零
            ' 更新到下一个工作日，为下一行任务做准备
            stDate = Application.WorksheetFunction.WorkDay_Intl(stDate, 1, 1, holidayRange)
        Else
            ' 工时>7小时，当天用满7小时，起止日期仍为当前工作日
            Cells(currentRow, "D").Value = stDate
            Cells(currentRow, "E").Value = stDate
            ' 计算剩余工时，带入下一个工作日处理
            eTime = eTime - tTime
            ' 更新到下一个工作日
            stDate = Application.WorksheetFunction.WorkDay_Intl(stDate, 1, 1, holidayRange)
        End If
        
        currentRow = currentRow + 1
        ' 累加下一行的预估工时（如果存在）
        If Cells(currentRow, "C").Value <> "" Then
            eTime = eTime + Cells(currentRow, "C").Value
        End If
    Loop
End Sub

修复说明 #

1. 移除Select和ActiveCell操作，改用行号直接引用单元格，提升代码稳定性
2. 修正超工时逻辑：当天工时超7小时时，起止日期保持为当天，剩余工时带入下一个工作日处理
3. 添加旧数据清空逻辑，避免残留之前的计算结果
4. 改用Double类型存储工时，支持非整数的预估工时（如3.5小时）

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