Excel宏自定义时间间隔分段统计耗时的代码修正求助

问题描述 #

需要实现基于开始时间（StartTime）、结束时间（EndTime）统计各时间间隔内耗时的VBA宏，示例效果：开始时间19:10、结束时间21:45，按1小时间隔统计结果为：

• 19:00区间：50分钟
• 20:00区间：60分钟
• 21:00区间：45分钟
  原有代码仅支持1小时间隔统计，调整为30分钟、50分钟等非1小时粒度时运行结果异常。

原代码问题根因 #

• 区间计算逻辑硬绑定小时维度：GetCurrentHourInterval函数直接取整小时为区间起点，不支持自定义间隔
• 间隔步长硬编码为1小时：固定使用TimeValue("1:0:0")作为区间跨度，无配置入口
• 循环判断完全依赖Hour()函数比对小时值，非整小时间隔下判断逻辑完全失效
• 区间查找范围固定为H7:H30，间隔变密后区间数量增加会出现查找不到的问题
• 同区间多记录直接覆盖值，没有做耗时累加

修改后完整代码 #

首先在Summary工作表的D5单元格填写统计间隔（单位：分钟，例如填30即为30分钟间隔、填50即为50分钟间隔，默认填60为1小时间隔），再使用以下代码：

Private wb As Workbook
Private ws As Worksheet
Private ws2 As Worksheet
Private srchRng As Range

' 通用区间计算函数：根据时间和间隔分钟数返回所属区间起点
Public Function GetCurrentInterval(ByVal inputTime As Date, ByVal intervalMinutes As Long) As Date
    Dim totalMinutes As Long
    totalMinutes = Hour(inputTime) * 60 + Minute(inputTime)
    Dim intervalOffset As Long
    intervalOffset = (totalMinutes \ intervalMinutes) * intervalMinutes
    GetCurrentInterval = TimeSerial(intervalOffset \ 60, intervalOffset Mod 60, 0)
End Function

Public Sub GetHoursSpentPerInterval()
   Set wb = Workbooks(ThisWorkbook.Name)
   Set ws = wb.Sheets("Summary")
   Set ws2 = wb.Sheets("Raw Data")
   
   Dim startTime As Date
   Dim endTime As Date
   Dim currentInterval As Date
   Dim nextInterval As Date
   Dim lRow As Long
   Dim agntSel As String, statSel As String
   ' 读取配置的统计间隔（单位：分钟）
   Dim intervalMin As Long
   intervalMin = ws.Range("D5").Value
   If intervalMin <= 0 Then intervalMin = 60 ' 默认1小时间隔
   Dim intervalSpan As Date
   intervalSpan = TimeSerial(0, intervalMin, 0)
   
   ws.Select
   agntSel = Range("D4").Value
   statSel = Range("D3").Value
   Range("I6").Value = statSel
   Range("I7:I54").ClearContents
   ' 自动填充对应间隔的时间区间
   Range("J8").Copy
   Range("H8").PasteSpecial Paste:=xlPasteFormulas
   Application.CutCopyMode = False
   Range("H8").AutoFill Destination:=Range("H8:H54")
   ' 公式转值
   Range("H8:H54").Value = Range("H8:H54").Value
   Range("A1").Select

   ws2.Select
   lRow = Cells(Rows.Count, 1).End(xlUp).Row

   For a = 2 To lRow
      startTime = Range("M" & a).Value
      endTime = Range("N" & a).Value
      ' 过滤无效时间行
      If startTime = 0 Or endTime = 0 Or endTime < startTime Then GoTo NextRow
      
      If agntSel = Range("A" & a).Value And statSel = Range("B" & a).Value Then
         currentInterval = GetCurrentInterval(startTime, intervalMin)
         ' 通用循环：直到区间超过结束时间才终止，不依赖小时维度判断
         Do While currentInterval < endTime
            nextInterval = currentInterval + intervalSpan
            ' 查找对应区间单元格，匹配整值避免查找错误
            Set srchRng = ws.Range("H:H").Find(what:=currentInterval, LookIn:=xlValues, lookat:=xlWhole)
            If Not srchRng Is Nothing Then
                Dim spent As Date
                ' 计算当前区间内的耗时
                If nextInterval > endTime Then
                    spent = endTime - startTime
                Else
                    spent = nextInterval - startTime
                End If
                ' 累加耗时，支持同一区间多条记录叠加
                srchRng.Offset(0, 1).Value = srchRng.Offset(0, 1).Value + spent
                ' 更新下一轮的起始时间
                startTime = nextInterval
            End If
            currentInterval = nextInterval
         Loop
      End If
NextRow:
   Next
   
   ws.Select
   ' 释放对象内存
   Set srchRng = Nothing
   Set ws2 = Nothing
   Set ws = Nothing
   Set wb = Nothing
End Sub

使用说明 #

• 配置间隔：在Summary表D5单元格输入需要的统计间隔分钟数，支持1-1440之间的任意正整数
• 区间列：H列会自动填充对应间隔的所有时间区间起点，如果用小于10分钟的细粒度间隔，需要把H列的自动填充范围扩大，预留足够行数覆盖全天所有区间
• 格式设置：I列耗时单元格建议设置格式为[h]:mm，可正确显示超过1小时的累计耗时

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