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
Driver As Integer
Dt As Date
Miles As Long
End Type
Type typMstRec
Car As Integer
DT_Miles() As typDt_MilesRec
End Type
Type typBin
Dt_Hr As Date
Miles As Long
End Type
Type typDriver
Driver As Integer
Bin() As typBin
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 Car As Integer
Dim Driver As Integer
Dim CarIdx 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
Car = Trim(ws.Cells(RowNo, CarNoCol))
Driver = Trim(ws.Cells(RowNo, DriverCol))
CarIdx = FindCarIdx(Car, MstRec)
I = UBound(MstRec(CarIdx).DT_Miles) + 1
ReDim Preserve MstRec(CarIdx).DT_Miles(I)
MstRec(CarIdx).DT_Miles(I).Driver = Driver
MstRec(CarIdx).DT_Miles(I).Miles = Val(ws.Cells(RowNo, StartMileCol))
MstRec(CarIdx).DT_Miles(I).Dt = CDate(ws.Cells(RowNo, DateCol) & " " & CDate(ws.Cells(RowNo, StartTimeCol)))
tempStartTime = MstRec(CarIdx).DT_Miles(I).Dt
Call InsertRec(MstRec, CarIdx)
I = UBound(MstRec(CarIdx).DT_Miles) + 1
ReDim Preserve MstRec(CarIdx).DT_Miles(I)
MstRec(CarIdx).DT_Miles(I).Driver = Driver
MstRec(CarIdx).DT_Miles(I).Miles = Val(ws.Cells(RowNo, EndMileCol))
MstRec(CarIdx).DT_Miles(I).Dt = CDate(ws.Cells(RowNo, DateCol) & " " & CDate(ws.Cells(RowNo, EndTimeCol)))
If tempStartTime > MstRec(CarIdx).DT_Miles(I).Dt Then
MstRec(CarIdx).DT_Miles(I).Dt = DateAdd("D", 1, MstRec(CarIdx).DT_Miles(I).Dt)
End If
Call InsertRec(MstRec, CarIdx)
End If
Next RowNo
Call OutputAll(MstRec)
MsgBox "Complete", vbInformation
End Sub
Function InsertRec(Rec() As typMstRec, CarIdx As Integer)
Dim I As Long
Dim xRec As typDt_MilesRec
Dim MaxIdx As Integer
MaxIdx = UBound(Rec(CarIdx).DT_Miles)
'***** This function sorts the last record into the correct location
For I = MaxIdx - 1 To 1 Step -1
If Rec(CarIdx).DT_Miles(I).Dt > Rec(CarIdx).DT_Miles(I + 1).Dt Then
xRec = Rec(CarIdx).DT_Miles(I + 1)
Rec(CarIdx).DT_Miles(I + 1) = Rec(CarIdx).DT_Miles(I)
Rec(CarIdx).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 CarIdx 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 CarIdx = 1 To UBound(MstRec)
Call OutputData(ws, MstRec(CarIdx), MstRec(CarIdx).Car)
'Debug.Print MstRec(CarIdx).Car
Next CarIdx
End Function
Function OutputData(ws As Worksheet, MstRec As typMstRec, Car As Integer)
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 DriverIdx As Integer
Dim BinIdx As Integer
Dim StartHr As Integer
Dim EndHr As Integer
Dim HourDiff As Integer
Dim tempTime As Date
Dim Drivers() As typDriver
ReDim Drivers(0)
ReDim Drivers(0).Bin(0)
RowNo = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row + 1
For I = 2 To UBound(MstRec.DT_Miles)
If MstRec.DT_Miles(I).Driver <> MstRec.DT_Miles(I - 1).Driver Then
GoTo NextRec
End If
DriverIdx = FindDriverIdx(MstRec.DT_Miles(I).Driver, Drivers)
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, Drivers(DriverIdx).Bin)
Drivers(DriverIdx).Bin(BinIdx).Miles = Drivers(DriverIdx).Bin(BinIdx).Miles + ElapsedMiles
Case Else
'***** Determine fractional time for 1st hour
BinIdx = FindBin_DT_HR(StartTime, Drivers(DriverIdx).Bin)
tempTime = CDate(Format(StartTime, "MM/DD/YY HH:00:00"))
tempMins = DateDiff("n", StartTime, DateAdd("h", 1, tempTime))
Perc = tempMins / ElapsedMins
Drivers(DriverIdx).Bin(BinIdx).Miles = Drivers(DriverIdx).Bin(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, Drivers(DriverIdx).Bin)
Drivers(DriverIdx).Bin(BinIdx).Miles = Drivers(DriverIdx).Bin(BinIdx).Miles + (ElapsedMiles * Perc)
tempTime = DateAdd("h", 1, tempTime)
Loop
'***** Determine fractional time for Last hour
BinIdx = FindBin_DT_HR(EndTime, Drivers(DriverIdx).Bin)
tempTime = CDate(Format(EndTime, "MM/DD/YY HH:00:00"))
tempMins = DateDiff("n", tempTime, EndTime)
Perc = tempMins / ElapsedMins
Drivers(DriverIdx).Bin(BinIdx).Miles = Drivers(DriverIdx).Bin(BinIdx).Miles + (ElapsedMiles * Perc)
End Select
End If
NextRec:
Next I
For DriverIdx = 1 To UBound(Drivers)
For I = 1 To UBound(Drivers(DriverIdx).Bin)
ws.Cells(RowNo, 1) = CDate(Format(Drivers(DriverIdx).Bin(I).Dt_Hr, "MM/DD/YY"))
ws.Cells(RowNo, 2) = Drivers(DriverIdx).Driver
ws.Cells(RowNo, 3) = Car
ws.Cells(RowNo, 4) = Format(Drivers(DriverIdx).Bin(I).Dt_Hr, "HH:MM") & " ~ " & Format(Drivers(DriverIdx).Bin(I).Dt_Hr, "HH:59")
ws.Cells(RowNo, "E") = Drivers(DriverIdx).Bin(I).Miles
RowNo = RowNo + 1
Next I
Next DriverIdx
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 FindDriverIdx(ByVal Driver As String, Drivers() As typDriver) As Integer
Dim I As Integer
For I = 1 To UBound(Drivers)
If Driver = Drivers(I).Driver Then
FindDriverIdx = I
Exit Function
End If
Next I
ReDim Preserve Drivers(I)
Drivers(I).Driver = Driver
ReDim Preserve Drivers(I).Bin(0)
FindDriverIdx = I
End Function
Function FindCarIdx(ByVal Car As String, Rec() As typMstRec) As Integer
Dim I As Integer
For I = 1 To UBound(Rec)
If Car = Rec(I).Car Then
FindCarIdx = I
Exit Function
End If
Next I
ReDim Preserve Rec(I)
Rec(I).Car = Car
ReDim Preserve Rec(I).DT_Miles(0)
FindCarIdx = I
End Function
