重叠总活动持续时间计算

Question

我试图计算设备实时的总持续时间。 如果设备只有一个服务，那么实时时间事件之间没有重叠。 具有多个服务的设备的订单的问题每个可以与多个其他时间重叠。

我需要计算每个设备ID然后保留计算公式中的计算的总时间。现场时间。 我是编程新手，我无法找到解决方案。 请支持

Sub Cul_Eq_Live_Time()

Application.ScreenUpdating = False


 Dim n As Long, lr_LT As Integer, lr_data As Integer
 Dim z As Integer, y As Integer, x As Integer, EqID As String, iLoop As Integer, No_CCTs As Integer

 Dim xDate As Date, yDate As Date, aDate As Date, bData As Date, iDate As Date, eDate As Date, Diff As Integer, EqLiveT As Long, T As Integer, tRange As Range
 Dim nDate As Date, dDate As Date


  lr_LT = Sheets("Live Time").Range("F" & Rows.Count).End(xlUp).Row

  'initial cell in Tuning sheet & range

  T = 2
  Set tRange = Sheets("Tuning").Range("B2:C2000")

'loop all orders

 For n = 3 To lr_LT

 'get new EqID
EqID = Sheets("Live Time").Cells(n, "E").Value
' find if the cuont EqID is 1 then live time will be the same of the CCT live time.
y = Application.WorksheetFunction.CountIf(Sheets("Live Time").Range("E:E"), Sheets("Live Time").Cells(n, 5).Value)
If y <= 1 Then
Sheets("Live Time").Cells(n, "P").Value = Sheets("Live Time").Cells(n, "K").Value
GoTo End_n_Loop

End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' in the cae of Eq. more the one orders
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' if live time alredy culculated
If Application.WorksheetFunction.CountIf(Sheets("Tuning").Range("B:B"), Sheets("Live Time").Cells(n, "E").Value) >= 1 Then
Sheets("Live Time").Cells(n, "P").Value = Application.WorksheetFunction.VLookup(EqID, tRange, 2, False)
GoTo End_n_Loop
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' in the caee of above condition not found

'get iDate & eDate

iDate = Sheets("Live Time").Cells(n, "H").Value
eDate = Sheets("Live Time").Cells(n, "I").Value
Diff = 0
EqLiveT = 0
No_CCTs = 1
xDate = iDate
yDate = eDate


If eDate = 0 Then
eDate = Date
End If

' iLoop for the Eq. that have more the one orders

For iLoop = n + 1 To lr_LT

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

If Sheets("Live Time").Cells(iLoop, "H").Value <> EqID Then
GoTo End_iLoop
End If

' count the nomber of CCt for this Eq.

No_CCTs = No_CCTs + 1

' in the case of the CCT live eDate = today
If Sheets("Live Time").Cells(iLoop, "I").Value = 0 Then
dDate = Date
End If

' update the dates

aDate = Sheets("Live Time").Cells(iLoop, "H").Value
bDate = Sheets("Live Time").Cells(iLoop, "I").Value

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''''''''''''''' x<-------->y


''''''''' a<-------->b

If xDate >= aDate And xDate < bDate And yDate >= bDate Then

nDate = aDate
dDate = yDate
GoTo End_iLoop

End If

''''''''''''''' x<-------->y


''''''''''''''''''' a<-------->b
If CDate(xDate) < CDate(aDate) And CDate(yDate) > CDate(aDate) And CDate(yDate) <= CDate(bDate) Then

nDate = xDate
dDate = bDate
GoTo End_iLoop

End If

''''''''''''''' x<-------->y


''''''''''' a<---------------->b
If xDate > aDate And xDate < bDate And yDate >= aDate And yDate <= bDate Then
nDate = aDate
dDate = bDate
GoTo End_iLoop

End If

''''''' x<------------------>y


''''''''''' a<----------->b
If xDate < aDate And yDate > bDate And aDate > yDate Then
nDate = xDate
dDate = yDate
GoTo End_iLoop

End If

''''''' x<------------------>y ''''''''''' a<----------->b
If yDate > aDate And xDate > aDate And bDate > yDate Then
nDate = xDate
dDate = yDate
Diff = Diff + (aDate - yDate)
GoTo End_iLoop
End If

End_iLoop:

Next iLoop

'AfterLoop

EqLiveT = nDate - dDate - Diff

'EqLiveT = EqLiveT - Diff

Sheets("Live Time").Cells(n, "P").Value = EqLiveT
Sheets("Tuning").Cells(T, "A").Value = T - 1
Sheets("Tuning").Cells(T, "B").Value = EqID
Sheets("Tuning").Cells(T, "C").Value = EqLiveT
Sheets("Tuning").Cells(T, "D").Value = No_CCTs
T = T + 1

End_n_Loop:

Next n

MsgBox "Done"

Application.ScreenUpdating = True


End Sub