设备在线时长重叠总时长计算及VBA代码优化求助

嗨，我完全理解你要解决的核心需求：当一个设备对应多个服务时段时，必须合并重叠或连续的时段，才能算出真实的总在线时长。你的思路方向是对的，但原代码存在几个关键的逻辑漏洞和细节错误，我来帮你修正并优化整个方案。

原代码的主要问题 #

• 变量名笔误：bData As Date 应该是 bDate As Date，这会直接导致编译错误
• 循环终止条件错误：判断设备ID时用了Sheets("Live Time").Cells(iLoop, "H").Value <> EqID，但EqID来自E列，应该判断E列的值
• 日期比较逻辑覆盖不全：原有的几个If条件无法覆盖所有重叠/连续场景（比如完全包含、部分重叠、时段相邻等）
• 时长计算逻辑错误：EqLiveT = nDate - dDate - Diff 会得到负数，正确的计算应该是结束日期减开始日期
• 未完整收集设备时段：原循环只从n+1开始，会漏掉当前行之前的同设备记录

修正优化后的代码 #

下面是重写后的代码，采用收集所有时段→排序→合并重叠区间→计算总时长的标准流程，逻辑更清晰，能覆盖所有场景：

Sub Cul_Eq_Live_Time()
    Application.ScreenUpdating = False
    Dim wsLiveTime As Worksheet, wsTuning As Worksheet
    Dim lrLiveTime As Long, lrTuning As Long
    Dim eqID As String, i As Long, j As Long, k As Long
    Dim timeRanges As Collection
    Dim currentStart As Date, currentEnd As Date
    Dim tempStart As Date, tempEnd As Date
    Dim totalLiveTime As Double
    Dim isCalculated As Boolean
    
    ' 初始化工作表对象，避免多次重复调用Sheets()，提升效率
    Set wsLiveTime = ThisWorkbook.Sheets("Live Time")
    Set wsTuning = ThisWorkbook.Sheets("Tuning")
    lrLiveTime = wsLiveTime.Range("E" & wsLiveTime.Rows.Count).End(xlUp).Row
    lrTuning = wsTuning.Range("B" & wsTuning.Rows.Count).End(xlUp).Row
    If lrTuning < 2 Then lrTuning = 2 ' 确保从第二行开始写入Tuning表
    
    ' 遍历每一行设备数据
    For i = 3 To lrLiveTime
        eqID = wsLiveTime.Cells(i, "E").Value
        isCalculated = False
        
        ' 1. 先检查Tuning表是否已经计算过该设备的时长，避免重复工作
        On Error Resume Next
        totalLiveTime = Application.WorksheetFunction.VLookup(eqID, wsTuning.Range("B:C"), 2, False)
        If Err.Number = 0 Then
            wsLiveTime.Cells(i, "P").Value = totalLiveTime
            isCalculated = True
        End If
        On Error GoTo 0
        
        If isCalculated Then GoTo NextRow
        
        ' 2. 检查该设备是否只有一条记录，直接复用K列的时长
        If Application.WorksheetFunction.CountIf(wsLiveTime.Range("E:E"), eqID) <= 1 Then
            totalLiveTime = wsLiveTime.Cells(i, "K").Value
            wsLiveTime.Cells(i, "P").Value = totalLiveTime
            ' 同步写入Tuning表
            wsTuning.Cells(lrTuning, "B").Value = eqID
            wsTuning.Cells(lrTuning, "C").Value = totalLiveTime
            wsTuning.Cells(lrTuning, "D").Value = 1
            lrTuning = lrTuning + 1
            GoTo NextRow
        End If
        
        ' 3. 收集该设备的所有时段，处理未结束的记录（结束日期为0时设为当天）
        Set timeRanges = New Collection
        For j = 3 To lrLiveTime
            If wsLiveTime.Cells(j, "E").Value = eqID Then
                tempStart = wsLiveTime.Cells(j, "H").Value
                tempEnd = wsLiveTime.Cells(j, "I").Value
                If tempEnd = 0 Then tempEnd = Date
                ' 将时段作为数组存入集合，方便后续排序
                timeRanges.Add Array(tempStart, tempEnd)
            End If
        Next j
        
        ' 4. 对时段按开始日期排序，这是合并重叠区间的前提
        Dim tempArr As Variant
        For j = 1 To timeRanges.Count - 1
            For k = j + 1 To timeRanges.Count
                If timeRanges(j)(0) > timeRanges(k)(0) Then
                    tempArr = timeRanges(j)
                    timeRanges(j) = timeRanges(k)
                    timeRanges(k) = tempArr
                End If
            Next k
        Next j
        
        ' 5. 合并重叠/连续的时段
        totalLiveTime = 0
        If timeRanges.Count > 0 Then
            currentStart = timeRanges(1)(0)
            currentEnd = timeRanges(1)(1)
            
            For j = 2 To timeRanges.Count
                tempStart = timeRanges(j)(0)
                tempEnd = timeRanges(j)(1)
                
                ' 如果当前时段与已合并的时段重叠或连续，就合并它们
                If tempStart <= currentEnd Then
                    currentEnd = IIf(tempEnd > currentEnd, tempEnd, currentEnd)
                Else
                    ' 不重叠则计算当前合并时段的时长，然后开始新的合并周期
                    totalLiveTime = totalLiveTime + (currentEnd - currentStart)
                    currentStart = tempStart
                    currentEnd = tempEnd
                End If
            Next j
            ' 加上最后一个合并时段的时长
            totalLiveTime = totalLiveTime + (currentEnd - currentStart)
        End If
        
        ' 6. 将结果写入Live Time表和Tuning表
        wsLiveTime.Cells(i, "P").Value = totalLiveTime
        wsTuning.Cells(lrTuning, "B").Value = eqID
        wsTuning.Cells(lrTuning, "C").Value = totalLiveTime
        wsTuning.Cells(lrTuning, "D").Value = timeRanges.Count
        lrTuning = lrTuning + 1
        
NextRow:
    Next i
    
    MsgBox "设备在线时长计算完成！", vbInformation
    Application.ScreenUpdating = True
End Sub

代码关键说明 #

• 工作表对象初始化：用wsLiveTime和wsTuning代替多次调用Sheets()，既提升代码效率，也让可读性更强
• 重复计算检查：用VLookup快速判断Tuning表是否已有该设备的计算结果，避免做无用功
• 时段收集与排序：先把同一设备的所有时段收集起来并按开始日期排序，这是合并重叠区间的核心前提
• 重叠合并逻辑：遍历排序后的时段，将重叠或连续的时段合并成一个大时段，确保没有重复计算
• 时长计算：用结束日期 - 开始日期得到天数，如果需要精确到小时/分钟，只需要把结果乘以24（转小时）或1440（转分钟）即可

注意事项 #

• 确保Live Time表的E列是设备ID，H列是开始日期，I列是结束日期（0表示未结束），K列是单条记录的时长，P列是要写入的总在线时长
• 如果你的日期包含时间部分，代码也能正常计算，结果会精确到天的小数部分（比如0.5就是12小时）

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