Option Explicit
Const DateCol As Integer = 1
Const StartTimeCol As Integer = 2
Const EndTimeCol As Integer = 3
Const DriverCol As Integer = 4
Const CarNoCol As Integer = 5
Const StartMileCol As Integer = 6
Const EndMileCol As Integer = 7
Type typHourRec
Used As Boolean
MinMin As Long
MaxMin As Long
MinMile As Long
MaxMile As Long
End Type
Type typRec
Key As String
HrDetail(24) As typHourRec
End Type
Sub Process()
Dim ws As Worksheet
Dim Rec() As typRec
Dim Key As String
Dim KeyIdx As Integer
Dim RowNo As Long
Dim LastRow As Long
Dim I As Long
ReDim Rec(0)
Set ws = ThisWorkbook.Worksheets(1)
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For RowNo = 2 To LastRow
Key = Trim(ws.Cells(RowNo, DateCol)) & "~" & Trim(ws.Cells(RowNo, DriverCol)) & "~" & Trim(ws.Cells(RowNo, CarNoCol))
KeyIdx = FindKeyIdx(Key, Rec)
Debug.Print KeyIdx
If Len(Trim(ws.Cells(RowNo, StartTimeCol))) > 1 Then
Call UpdateRec(Rec(KeyIdx).HrDetail, StartTimeCol, StartMileCol, ws, RowNo)
Call UpdateRec(Rec(KeyIdx).HrDetail, EndTimeCol, EndMileCol, ws, RowNo)
End If
Next RowNo
Call OutputAll(Rec)
End Sub
Function OutputAll(Rec() As typRec)
Dim ws As Worksheet
Dim RowNo As Integer
Dim KeyIdx As Integer
Dim v As Variant
Dim I As Integer
Set ws = ThisWorkbook.Worksheets(2)
ws.Cells.ClearContents
RowNo = 1
ws.Cells(RowNo, 1) = "Date"
ws.Cells(RowNo, 2) = "Driver"
ws.Cells(RowNo, 3) = "Car"
ws.Cells(RowNo, 4) = "Bucket"
ws.Cells(RowNo, 5) = "Kms"
For KeyIdx = 1 To UBound(Rec)
Call OutputData(ws, Rec(KeyIdx).HrDetail, Rec(KeyIdx).Key)
Next KeyIdx
End Function
Function OutputData(ws As Worksheet, HrDetail() As typHourRec, Key As String)
Dim I As Integer
Dim RowNo As Long
Dim v As Variant
Dim J As Integer
Dim ElapsedMin As Long
Dim ElapsedMiles As Long
Dim Perc As Single
Dim tempMin As Integer
Dim tempMiles As Long
RowNo = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row + 1
For I = 2 To UBound(HrDetail)
If HrDetail(I).Used Then
v = Split(Key, "~")
If UBound(v) >= 0 Then
For J = 0 To 2
ws.Cells(RowNo, J + 1) = v(J)
Debug.Print v(J)
Next J
End If
ElapsedMiles = 0
ElapsedMiles = HrDetail(I).MaxMile - HrDetail(I).MinMile
'***** Determine Offset Adj for the Start of the Hour
If HrDetail(I - 1).Used Then
tempMin = (60 - HrDetail(I - 1).MaxMin) + HrDetail(I).MinMin
tempMiles = HrDetail(I).MinMile - HrDetail(I - 1).MaxMile
Perc = HrDetail(I).MinMin / tempMin
ElapsedMiles = ElapsedMiles + (tempMiles * Perc)
End If
'***** Determine Offset Ady for the Top of the Hour
If (I < 24) Then
If HrDetail(I + 1).Used Then
tempMin = (60 - HrDetail(I).MaxMin) + HrDetail(I + 1).MinMin
tempMiles = HrDetail(I + 1).MinMile - HrDetail(I).MaxMile
Perc = (60 - HrDetail(I).MaxMin) / tempMin
ElapsedMiles = ElapsedMiles + (tempMiles * Perc)
End If
End If
'ws.Cells(RowNo, 1) = Dt
'ws.Cells(RowNo, 2) = CarNo
ws.Cells(RowNo, 4) = I & ":00" & " ~ " & (I + 1) & ":00"
ws.Cells(RowNo, 5) = ElapsedMiles
RowNo = RowNo + 1
End If
Next I
End Function
Function UpdateRec(HrDetail() As typHourRec, ByVal TimeColNo As Long, ByVal MileColNo As Long, ws As Worksheet, RowNo As Long)
Dim TempTime As Date
Dim Idx As Long
TempTime = CDate(ws.Cells(RowNo, TimeColNo))
Idx = Hour(TempTime)
Select Case HrDetail(Idx).Used
Case False
HrDetail(Idx).MaxMin = Minute(ws.Cells(RowNo, TimeColNo))
HrDetail(Idx).MinMin = Minute(ws.Cells(RowNo, TimeColNo))
HrDetail(Idx).MaxMile = Val(ws.Cells(RowNo, MileColNo))
HrDetail(Idx).MinMile = Val(ws.Cells(RowNo, MileColNo))
HrDetail(Idx).Used = True
Case True
HrDetail(Idx).MaxMile = UpdateMax(HrDetail(Idx).MaxMile, Val(ws.Cells(RowNo, MileColNo)))
HrDetail(Idx).MaxMin = UpdateMax(HrDetail(Idx).MaxMin, Minute(ws.Cells(RowNo, TimeColNo)))
HrDetail(Idx).MinMile = UpdateMin(HrDetail(Idx).MinMile, Val(ws.Cells(RowNo, MileColNo)))
HrDetail(Idx).MinMin = UpdateMin(HrDetail(Idx).MinMin, Minute(ws.Cells(RowNo, TimeColNo)))
End Select
End Function
Function FindKeyIdx(ByVal Key As String, Rec() As typRec) As Integer
Dim I As Integer
For I = 1 To UBound(Rec)
If Key = Rec(I).Key Then
FindKeyIdx = I
Exit Function
End If
Next I
ReDim Preserve Rec(I)
Rec(I).Key = Key
'ReDim Rec(I).HrDetail(0)
FindKeyIdx = I
End Function
Function UpdateMin(arrVal As Long, wsVal As Long) As Long
If wsVal < arrVal Then
UpdateMin = wsVal
Else
UpdateMin = arrVal
End If
End Function
Function UpdateMax(arrVal As Long, wsVal As Long)
If wsVal > arrVal Then
UpdateMax = wsVal
Else
UpdateMax = arrVal
End If
End Function
