如何用VBA按时间区间汇总Excel特定数据并修正代码问题

需求说明 #

• Excel文件中B列为日期时间数据，C列为时长数据
• 需将同一日期的行按3个时间区间分组汇总：
  • 区间1：6:00 AM - 2:00 PM
  • 区间2：2:00 PM - 10:00 PM
  • 区间3：10:00 PM - 6:00 AM
• 仅输出按日期分组的区间时长汇总结果，无需显示统计过程

原代码问题分析 #

1. 未声明关键变量（i、timeInterval1、dateInterval1等），易引发运行错误
2. 每次匹配区间时错误重置其他区间的累计值，导致同日期跨区间的汇总数据丢失
3. 用完整日期时间（含时分秒）与下一行对比，会因时间差异误判为不同日期
4. 累计变量未在新日期开始时重置，导致不同日期的汇总数据叠加

修正后的VBA代码 #

Sub Filter_Data()
    '声明变量
    Dim ws As Worksheet
    Dim newSheet As Worksheet
    Dim currDate As Date
    Dim currTime As Date
    Dim lastRow As Long
    Dim i As Long
    Dim currentSummaryDate As Date
    Dim sumInterval1 As Double
    Dim sumInterval2 As Double
    Dim sumInterval3 As Double
    
    '设置数据源工作表
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    '创建或获取结果工作表
    On Error Resume Next
    Set newSheet = ThisWorkbook.Sheets("Filtered Data")
    On Error GoTo 0
    If newSheet Is Nothing Then
        Set newSheet = ThisWorkbook.Sheets.Add
        newSheet.Name = "Filtered Data"
    End If
    
    '清空结果表现有数据（保留表头）
    newSheet.Cells.Clear
    newSheet.Range("A1").Value = "Date"
    newSheet.Range("B1").Value = "Time Interval 1 (6:00 AM - 2:00 PM)"
    newSheet.Range("C1").Value = "Time Interval 2 (2:00 PM - 10:00 PM)"
    newSheet.Range("D1").Value = "Time Interval 3 (10:00 PM - 6:00 AM)"
    
    '获取数据最后一行
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    If lastRow < 2 Then Exit Sub '无数据直接退出
    
    '初始化第一个日期的汇总变量
    currentSummaryDate = DateValue(ws.Cells(2, "B").Value)
    sumInterval1 = 0
    sumInterval2 = 0
    sumInterval3 = 0
    
    '从第2行开始遍历数据（假设第1行是表头）
    For i = 2 To lastRow
        currDate = DateValue(ws.Cells(i, "B").Value)
        currTime = TimeValue(ws.Cells(i, "B").Value)
        
        '判断当前时间所属区间并累加时长
        If currTime >= TimeValue("6:00 AM") And currTime < TimeValue("2:00 PM") Then
            sumInterval1 = sumInterval1 + ws.Cells(i, "C").Value
        ElseIf currTime >= TimeValue("2:00 PM") And currTime < TimeValue("10:00 PM") Then
            sumInterval2 = sumInterval2 + ws.Cells(i, "C").Value
        Else
            sumInterval3 = sumInterval3 + ws.Cells(i, "C").Value
        End If
        
        '判断是否需要输出当前日期的汇总结果（到最后一行或日期变更）
        If i = lastRow Or currDate <> DateValue(ws.Cells(i + 1, "B").Value) Then
            '找到结果表的下一行空行
            Dim nextRow As Long
            nextRow = newSheet.Cells(newSheet.Rows.Count, "A").End(xlUp).Row + 1
            
            '写入汇总数据
            newSheet.Range("A" & nextRow).Value = currentSummaryDate
            newSheet.Range("B" & nextRow).Value = sumInterval1
            newSheet.Range("C" & nextRow).Value = sumInterval2
            newSheet.Range("D" & nextRow).Value = sumInterval3
            
            '重置汇总变量为下一个日期准备
            If i < lastRow Then
                currentSummaryDate = DateValue(ws.Cells(i + 1, "B").Value)
                sumInterval1 = 0
                sumInterval2 = 0
                sumInterval3 = 0
            End If
        End If
    Next i
    
    '格式化结果表日期列
    newSheet.Columns("A").NumberFormat = "yyyy-mm-dd"
End Sub

代码说明 #

• 补全变量声明，避免隐式类型错误
• 仅在日期变更时重置汇总变量，保证同日期所有区间数据正确累加
• 使用DateValue提取纯日期进行比较，避免时间干扰导致的分组错误
• 清空结果表原有数据，避免重复输出
• 遍历从第2行开始（假设原数据第1行是表头），无表头可修改为i=1
• 最后格式化日期列，保证显示统一

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