修改VBA Work_Days函数计算工作日小时数出错，求解决方案

问题描述 #

原微软官网的VBA函数可正常计算两个日期间的工作日天数，但修改为计算工作日小时数时（仅将代码中"d"改为"h"并将相关数值乘以24），计算2022-05-05 09:05:19至2022-05-05 15:45:14的差值时，结果为24小时而非实际约6小时。

原代码 #

Function Work_Days(BegDate As Variant, EndDate As Variant) As Integer
 
 Dim WholeWeeks As Variant
 Dim DateCnt As Variant
 Dim EndDays As Integer
 
 On Error GoTo Err_Work_Days
 
 BegDate = DateValue(BegDate)
 EndDate = DateValue(EndDate)
 WholeWeeks = DateDiff("w", BegDate, EndDate)
 DateCnt = DateAdd("ww", WholeWeeks, BegDate)
 EndDays = 0
 
 Do While DateCnt <= EndDate
 If Format(DateCnt, "ddd") <> "Sun" And _
 Format(DateCnt, "ddd") <> "Sat" Then
 EndDays = EndDays + 1
 End If
 DateCnt = DateAdd("d", 1, DateCnt)
 Loop
 
 Work_Days = WholeWeeks * 5 + EndDays
 
Exit Function
 
Err_Work_Days:
 
 ' If either BegDate or EndDate is Null, return a zero
 ' to indicate that no workdays passed between the two dates.
 
 If Err.Number = 94 Then
 Work_Days = 0
 Exit Function
 Else
' If some other error occurs, provide a message.
 MsgBox "Error " & Err.Number & ": " & Err.Description
 End If
 
End Function

问题原因 #

• 时间信息丢失：原代码中DateValue(BegDate)和DateValue(EndDate)会丢弃输入的时间部分，仅保留日期，导致所有时间被视为当天0点，最终计算的是完整工作日的小时数（24小时），而非实际时间段。
• 逻辑未适配小时计算：原逻辑按天循环统计工作日天数，直接替换为小时循环后，未调整核心统计逻辑，无法准确计算跨小时的时间段。

修复后的代码 #

以下代码保留完整日期时间信息，按小时粒度统计工作日小时数（若需限制特定工作时段，可自行添加时间范围判断）：

Function Work_Hours(BegDate As Variant, EndDate As Variant) As Double
    Dim WholeWeeks As Variant
    Dim DateCnt As Variant
    Dim EndHours As Double
    Dim currentHour As Date
    
    On Error GoTo Err_Work_Hours
    
    ' 保留完整日期时间，不丢弃时间部分
    BegDate = CDate(BegDate)
    EndDate = CDate(EndDate)
    
    ' 计算完整周数，每周贡献5*24=120个工作日小时
    WholeWeeks = DateDiff("w", BegDate, EndDate)
    EndHours = WholeWeeks * 5 * 24
    
    ' 从BegDate开始，逐小时统计剩余天数内的工作日小时
    DateCnt = BegDate
    Do While DateCnt <= EndDate
        ' 判断当前小时所在日期是否为周末
        If Format(DateCnt, "ddd") <> "Sun" And Format(DateCnt, "ddd") <> "Sat" Then
            ' 计算当前小时的有效时长：处理开始/结束的非完整小时
            currentHour = DateSerial(Year(DateCnt), Month(DateCnt), Day(DateCnt)) + Hour(DateCnt) / 24
            If currentHour = DateSerial(Year(BegDate), Month(BegDate), Day(BegDate)) + Hour(BegDate) / 24 Then
                ' 开始小时：按实际剩余分钟数计算
                EndHours = EndHours + (DateAdd("h", 1, currentHour) - BegDate) * 24
            ElseIf currentHour = DateSerial(Year(EndDate), Month(EndDate), Day(EndDate)) + Hour(EndDate) / 24 Then
                ' 结束小时：按实际已过分钟数计算
                EndHours = EndHours + (EndDate - currentHour) * 24
            Else
                ' 完整小时，直接加1
                EndHours = EndHours + 1
            End If
        End If
        ' 按小时递进循环
        DateCnt = DateAdd("h", 1, DateCnt)
    Loop
    
    ' 保留两位小数，贴合实际时间差精度
    Work_Hours = Round(EndHours, 2)
    
Exit Function
 
Err_Work_Hours:
    ' 处理空值输入
    If Err.Number = 94 Then
        Work_Hours = 0
        Exit Function
    Else
        MsgBox "Error " & Err.Number & ": " & Err.Description
    End If
End Function

代码说明 #

• 替换DateValue为CDate，完整保留输入的日期时间信息。
• 完整周数按5*24小时计算，符合工作日全天时长逻辑。
• 针对开始和结束的非完整小时，按实际分钟数计算时长，避免统计误差。
• 结果保留两位小数，更贴合实际时间差的精度需求。

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