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 typDt_MilesRec
Dt As Date
Miles As Long
End Type
Type typMstRec
Key As String
DT_Miles() As typDt_MilesRec
End Type
Type typBin
Dt_Hr As Date
Miles As Long
End Type
Sub Process()
Dim ws As Worksheet
Dim ws3 As Worksheet
Dim MstRec() As typMstRec
Dim RowNo As Long
Dim LastRow As Long
Dim I As Long
Dim Key As String
Dim KeyIdx As Integer
Dim tempStartTime As Date
ReDim MstRec(0)
Set ws = ThisWorkbook.Worksheets(1)
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For RowNo = 2 To LastRow
If Len(Trim(ws.Cells(RowNo, StartTimeCol))) > 1 Then
Key = Trim(ws.Cells(RowNo, DriverCol)) & "~" & Trim(ws.Cells(RowNo, CarNoCol))
KeyIdx = FindKeyIdx(Key, MstRec)
I = UBound(MstRec(KeyIdx).DT_Miles) + 1
ReDim Preserve MstRec(KeyIdx).DT_Miles(I)
MstRec(KeyIdx).DT_Miles(I).Miles = Val(ws.Cells(RowNo, StartMileCol))
MstRec(KeyIdx).DT_Miles(I).Dt = CDate(ws.Cells(RowNo, DateCol) & " " & CDate(ws.Cells(RowNo, StartTimeCol)))
tempStartTime = MstRec(KeyIdx).DT_Miles(I).Dt
Call InsertRec(MstRec, KeyIdx)
I = UBound(MstRec(KeyIdx).DT_Miles) + 1
ReDim Preserve MstRec(KeyIdx).DT_Miles(I)
MstRec(KeyIdx).DT_Miles(I).Miles = Val(ws.Cells(RowNo, EndMileCol))
MstRec(KeyIdx).DT_Miles(I).Dt = CDate(ws.Cells(RowNo, DateCol) & " " & CDate(ws.Cells(RowNo, EndTimeCol)))
If tempStartTime > MstRec(KeyIdx).DT_Miles(I).Dt Then
MstRec(KeyIdx).DT_Miles(I).Dt = DateAdd("D", 1, MstRec(KeyIdx).DT_Miles(I).Dt)
End If
Call InsertRec(MstRec, KeyIdx)
End If
Next RowNo
Call OutputAll(MstRec)
MsgBox "Complete", vbInformation
End Sub
Function InsertRec(Rec() As typMstRec, IDX As Integer)
Dim I As Long
Dim xRec As typDt_MilesRec
Dim MaxIdx As Integer
MaxIdx = UBound(Rec(IDX).DT_Miles)
'***** This function sorts the last record into the correct location
For I = MaxIdx - 1 To 1 Step -1
If Rec(IDX).DT_Miles(I).Dt > Rec(IDX).DT_Miles(I + 1).Dt Then
xRec = Rec(IDX).DT_Miles(I + 1)
Rec(IDX).DT_Miles(I + 1) = Rec(IDX).DT_Miles(I)
Rec(IDX).DT_Miles(I) = xRec
Else
Exit Function
End If
Next I
End Function
Function OutputAll(MstRec() As typMstRec)
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) = "Datum"
ws.Cells(RowNo, 2) = "Ch"
ws.Cells(RowNo, 3) = "WP_Wagen"
ws.Cells(RowNo, 4) = "Hr"
ws.Cells(RowNo, 5) = "Km"
For KeyIdx = 1 To UBound(MstRec)
Call OutputData(ws, MstRec(KeyIdx), MstRec(KeyIdx).Key)
Debug.Print MstRec(KeyIdx).Key
Next KeyIdx
End Function
Function OutputData(ws As Worksheet, MstRec As typMstRec, Key As String)
Dim I As Integer
Dim RowNo As Long
Dim v As Variant
Dim J As Integer
Dim Perc As Single
Dim tempMins As Integer
Dim tempMiles As Long
Dim ElapsedMins As Integer
Dim ElapsedMiles As Long
Dim StartTime As Date
Dim EndTime As Date
Dim BinIdx As Integer
Dim StartHr As Integer
Dim EndHr As Integer
Dim HourDiff As Integer
Dim tempTime As Date
Dim arrBin() As typBin
ReDim arrBin(0)
RowNo = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row + 1
For I = 2 To UBound(MstRec.DT_Miles)
StartTime = MstRec.DT_Miles(I - 1).Dt
EndTime = MstRec.DT_Miles(I).Dt
ElapsedMiles = MstRec.DT_Miles(I).Miles - MstRec.DT_Miles(I - 1).Miles
If ElapsedMiles > 0 Then
ElapsedMins = DateDiff("n", MstRec.DT_Miles(I - 1).Dt, MstRec.DT_Miles(I).Dt)
HourDiff = DateDiff("h", StartTime, EndTime)
Select Case HourDiff
Case 0
BinIdx = FindBin_DT_HR(StartTime, arrBin)
arrBin(BinIdx).Miles = arrBin(BinIdx).Miles + ElapsedMiles
Case Else
'***** Determine fractional time for 1st hour
BinIdx = FindBin_DT_HR(StartTime, arrBin)
tempTime = CDate(Format(StartTime, "MM/DD/YY HH:00:00"))
tempMins = DateDiff("n", StartTime, DateAdd("h", 1, tempTime))
Perc = tempMins / ElapsedMins
arrBin(BinIdx).Miles = arrBin(BinIdx).Miles + (ElapsedMiles * Perc)
'Determine Full hour mileage between Start and End Time
Perc = 60 / ElapsedMins
tempTime = DateAdd("h", 1, StartTime)
Do While Hour(tempTime) < Hour(EndTime)
BinIdx = FindBin_DT_HR(tempTime, arrBin)
arrBin(BinIdx).Miles = arrBin(BinIdx).Miles + (ElapsedMiles * Perc)
tempTime = DateAdd("h", 1, tempTime)
Loop
'***** Determine fractional time for Last hour
BinIdx = FindBin_DT_HR(EndTime, arrBin)
tempTime = CDate(Format(EndTime, "MM/DD/YY HH:00:00"))
tempMins = DateDiff("n", tempTime, EndTime)
Perc = tempMins / ElapsedMins
arrBin(BinIdx).Miles = arrBin(BinIdx).Miles + (ElapsedMiles * Perc)
End Select
End If
Next I
v = Split(Key, "~")
For I = 1 To UBound(arrBin)
ws.Cells(RowNo, 1) = CDate(Format(arrBin(I).Dt_Hr, "MM/DD/YY"))
If UBound(v) >= 1 Then
ws.Cells(RowNo, 2) = v(0)
ws.Cells(RowNo, 3) = v(1)
End If
ws.Cells(RowNo, 4) = Format(arrBin(I).Dt_Hr, "HH:MM") & " ~ " & Format(arrBin(I).Dt_Hr, "HH:59")
ws.Cells(RowNo, "E") = arrBin(I).Miles
RowNo = RowNo + 1
Next I
End Function
Function FindBin_DT_HR(ByVal Dt As Date, Rec() As typBin) As Integer
Dim I As Integer
Dim tempDT As Date
tempDT = Format(Dt, "MM/DD/YY HH:00:00")
For I = 1 To UBound(Rec)
If tempDT = Rec(I).Dt_Hr Then
FindBin_DT_HR = I
Exit Function
End If
Next I
ReDim Preserve Rec(I)
Rec(I).Dt_Hr = tempDT
FindBin_DT_HR = I
End Function
Function FindKeyIdx(ByVal Key As String, Rec() As typMstRec) 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 Preserve Rec(I).DT_Miles(0)
FindKeyIdx = I
End Function
