# complicated way of dividing data



## bertusavius (Sep 24, 2012)

I have a table with a list of events that have ID, two time-values and two 'trip values'.




*ID*
*Timestart*
*Timestop*
*tripstart*
*tripstop*
25
6:55
7:55
259010
259030
25
7:06
7:55
259011
259030
25
7:11
7:57
259013
259030
25
7:17
7:57
259014
259030
25
7:23
7:57
259015
259030
25
7:27
7:59
259017
259031
25
7:29
7:58
259017
259031
25
7:40
7:59
259025
259031
25
8:11
8:21
259038
259043
25
8:41
9:07
259049
259063
25
8:48
9:16
259054
259064
78
13:24
13:34
259116
259122
78
13:40
14:14
259122
259134
78
13:45
14:22
259124
259136
78
13:54
14:22
259127
259136
78
14:03
14:23
259130
259136
78
14:35
14:58
259144
259148
78
14:36
14:58
259144
259148
78
14:43
15:06
259145
259150
78
14:52
15:38
259146
259162
78
15:19
15:42
259155
259163
78
15:27
15:47
259157
259164
78
15:54
16:02
259165
259167


<TBODY>

</TBODY>

<TBODY>

</TBODY>


To make things less abstract:
The trip-value is the value of a trip meter in a car in kilometers.
So the top record actualy says:
car nr 25 had an event that started at 06:55 at trip value 259010 and this event stopped at 07:55 coinciding with trip value 259030
You could say this is a list of events with corresponding accumulating properties, so wether the timeID starts or stops doesnt really matter. All the matters is that a certain time corresponds with a certain trip value.





Now wat I'd like is to create a measure that transforms and divides this information like this:




*ID*
*binID*
*distance travelled*
25
0700-0800
(value in kms)
25
0800-0900
(value in kms)
25
0900-1000
(value in kms)
78
0700-0800
(value in kms)
78
0800-0900
(value in kms)
78
0900-1000
(value in kms)


<TBODY>

</TBODY>

<TBODY>

</TBODY>



<TBODY>

</TBODY>
I have a table to relate to which contains binID, binstart and binstop
I also have a table for dates
Is it even worth contemplating to solve this in Powerpivot, because it seems quite daunting to me atm.




<TBODY>

</TBODY>


----------



## b.downey (Sep 24, 2012)

Are the "BinIDs" a reference to the "TimeStart"?  or something else?


----------



## bertusavius (Sep 25, 2012)

The bin-ID's represent a time window.
The refer to the timestart and timestop columns, yes.

I found a pretty similar problem on the MS SQL forum:
T-SQL 2005 to get 15 minutes SalesAmout average? 

I gues the topic title should include the word '_quantizing data'_ or_ 'rounding data'_. 


The problem would be easier to imagine if the time values were rounded to whole hours. It would then be easier to calculate the trip difference between to time values.
The tricky part is to extrapolate the right trip data that would correspond to a round time value.


----------



## bertusavius (Sep 25, 2012)

The bin-ID's represent a time window.
The refer to the timestart and timestop columns, yes.

I found a pretty similar problem on the MS SQL forum:
T-SQL 2005 to get 15 minutes SalesAmout average? 

I gues the topic title should include the word '_quantizing data'_ or_ 'rounding data'_. 


The problem would be easier to imagine if the time values were rounded to whole hours. It would then be easier to calculate the trip difference between to time values.
The tricky part is to extrapolate the right trip data that would correspond to a round time value.


----------



## bertusavius (Sep 25, 2012)

A bit more clarification(hopefully):


1) (raw data)unrounded time Atrip value Aunrounded time Btrip value B2) (step 1 of transformation)rounded time Acorrected trip value Arounded time Bcorrected trip value B

<COLGROUP><COL style="WIDTH: 92pt; mso-width-source: userset; mso-width-alt: 4461" width=122><COL style="WIDTH: 124pt; mso-width-source: userset; mso-width-alt: 6034" width=165><TBODY>

</TBODY>


3) (step 2 of transformation)from rounded time A to rounded time Bcorrected trip value B minus corrected trip value Aequals:distance travelled in time bin of rounded time (ie one hour)

<COLGROUP><COL style="WIDTH: 220pt; mso-width-source: userset; mso-width-alt: 10715" width=293><COL style="WIDTH: 268pt; mso-width-source: userset; mso-width-alt: 13056" width=357><TBODY>

</TBODY>


----------



## Laurent C (Sep 25, 2012)

Hi, you might want to start with a calculated column:
[estimated speed] = ([tripstop] -[tripstart]) / ([timestop] - [timestart])

At that point, this will turn to be a bucket problem, like the one you had before, except this time, you will have to multiply the calculated "time in bucket" by [estimated speed].


----------



## b.downey (Sep 25, 2012)

If I look at the first entry


*ID**Timestart**Timestop**tripstart**tripstop*256:557:55259010259030

<TBODY>

</TBODY>
The difference between the Trip Start and Trip Stop is 20

Based on the Bins,  5 Mins would be in the 6:00 hour and 55 mins in the 7:00 hour.    Should we be taling 5/60 percentage of the 20K and assign it to the 6:00 Bin and 55/60 percentage of the 20K and assign it to the 7:00 bin?


----------



## bertusavius (Sep 25, 2012)

@mr C:
interesting approach. As long as the intervals are small and there are many events per hour, the averages work quite well.
But I'm affraid they're not accurate enough.

I'd like the cumulative values of the buckets to be as close as or equal to the real trip data.




@b.downey
That is absolutely correct 


I wonder if this isn't some kind of standard mathematic problem.
Quantizing a set of data in predifined bits.

Ecspecially when you imagine the start and stop data to be interchangable:

ID - TimeValue - Tripvalue


----------



## b.downey (Sep 25, 2012)

Here is some VBA code that will produce the results requested

It expects the data to be in a Sheet Called "Sheet1"  (no spaces) and the results (matrix) will be placed in "Sheet2".   The code escentially prorates the miles accross the Bins based on the minutes in each BIN


```
Option Explicit
Type typRec
    ID As Integer
    BinArray(24) As Double
End Type
Sub Calc()
    Dim Rec() As typRec
    ReDim Rec(0)
    Dim ws As Worksheet
    
    Dim RowNo As Long
    
    Dim StartTime As Date
    Dim EndTime As Date
    
    Dim IdIdx As Integer
    Dim BinIdx As Integer
    Dim HourCnt As Integer
    Dim Miles As Long
    
    Dim TotalMin As Long
    Dim Min As Integer
    
    Dim Perc As Single
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    RowNo = 2
    For RowNo = 2 To 24
        IdIdx = FindIdx(ws.Cells(RowNo, 1), Rec)
        StartTime = ws.Cells(RowNo, 2)
        EndTime = ws.Cells(RowNo, 3)
        Miles = ws.Cells(RowNo, 5) - ws.Cells(RowNo, 4)
        HourCnt = Hour(EndTime) - Hour(StartTime)
        
        Select Case HourCnt
            Case 0
                BinIdx = Hour(StartTime)
                Rec(IdIdx).BinArray(BinIdx) = Rec(IdIdx).BinArray(BinIdx) + Miles
            Case Is > 0
                TotalMin = DateDiff("n", StartTime, EndTime)
                '***** Determine fractional time for 1st hour
                BinIdx = Hour(StartTime)
                Min = DateDiff("n", StartTime, CDate(BinIdx + 1 & ":00:00"))
                Perc = Min / TotalMin
                Rec(IdIdx).BinArray(BinIdx) = Rec(IdIdx).BinArray(BinIdx) + (Miles * Perc)
            
                Perc = 60 / TotalMin
                For BinIdx = Hour(StartTime) + 1 To Hour(EndTime) - 1
                    Rec(IdIdx).BinArray(BinIdx) = Rec(IdIdx).BinArray(BinIdx) + (Miles * Perc)
                Next BinIdx
                
                '***** Determine fractional time for Last hour
                BinIdx = Hour(EndTime)
                Min = DateDiff("n", CDate(BinIdx & ":00:00"), EndTime)
                Perc = Min / TotalMin
                Rec(IdIdx).BinArray(BinIdx) = Rec(IdIdx).BinArray(BinIdx) + (Miles * Perc)
            Case Else
    
        End Select
    Next RowNo
    
Call OutputResults(Rec)
End Sub
Function OutputResults(Rec() As typRec)
    Dim I As Integer
    Dim BinIdx As Integer
    Dim ws As Worksheet
    Dim RowNo As Long
    
    Set ws = ThisWorkbook.Worksheets("Sheet2")
    ws.Cells.ClearContents
    RowNo = 2
    For I = 1 To UBound(Rec)
        For BinIdx = 1 To 24
            If Rec(I).BinArray(BinIdx) > 0 Then
                ws.Cells(RowNo, 1) = Rec(I).ID
                ws.Cells(RowNo, 2) = BinIdx
                ws.Cells(RowNo, 3) = Rec(I).BinArray(BinIdx)
                RowNo = RowNo + 1
            End If
        Next BinIdx
    Next I
End Function
Function FindIdx(ID As Integer, Rec() As typRec) As Integer
    Dim I As Integer
    
    For I = 1 To UBound(Rec)
        If Rec(I).ID = ID Then
            FindIdx = I
            Exit Function
        End If
    Next I
    
    ReDim Preserve Rec(I)
    Rec(I).ID = ID
    FindIdx = I
    
End Function
```


----------



## bertusavius (Sep 26, 2012)

I really appreciate your help here.
Your solution works very well asigning the proper trip data to the right bins. 
The problem is that it accumulates to total trip data.

Attached a schematic representation of the problem. 
I hope it clarifies things.
I'm affraid it's in Dutch, but I think it speaks for itself.


----------



## bertusavius (Sep 24, 2012)

I have a table with a list of events that have ID, two time-values and two 'trip values'.




*ID*
*Timestart*
*Timestop*
*tripstart*
*tripstop*
25
6:55
7:55
259010
259030
25
7:06
7:55
259011
259030
25
7:11
7:57
259013
259030
25
7:17
7:57
259014
259030
25
7:23
7:57
259015
259030
25
7:27
7:59
259017
259031
25
7:29
7:58
259017
259031
25
7:40
7:59
259025
259031
25
8:11
8:21
259038
259043
25
8:41
9:07
259049
259063
25
8:48
9:16
259054
259064
78
13:24
13:34
259116
259122
78
13:40
14:14
259122
259134
78
13:45
14:22
259124
259136
78
13:54
14:22
259127
259136
78
14:03
14:23
259130
259136
78
14:35
14:58
259144
259148
78
14:36
14:58
259144
259148
78
14:43
15:06
259145
259150
78
14:52
15:38
259146
259162
78
15:19
15:42
259155
259163
78
15:27
15:47
259157
259164
78
15:54
16:02
259165
259167


<TBODY>

</TBODY>

<TBODY>

</TBODY>


To make things less abstract:
The trip-value is the value of a trip meter in a car in kilometers.
So the top record actualy says:
car nr 25 had an event that started at 06:55 at trip value 259010 and this event stopped at 07:55 coinciding with trip value 259030
You could say this is a list of events with corresponding accumulating properties, so wether the timeID starts or stops doesnt really matter. All the matters is that a certain time corresponds with a certain trip value.





Now wat I'd like is to create a measure that transforms and divides this information like this:




*ID*
*binID*
*distance travelled*
25
0700-0800
(value in kms)
25
0800-0900
(value in kms)
25
0900-1000
(value in kms)
78
0700-0800
(value in kms)
78
0800-0900
(value in kms)
78
0900-1000
(value in kms)


<TBODY>

</TBODY>

<TBODY>

</TBODY>



<TBODY>

</TBODY>
I have a table to relate to which contains binID, binstart and binstop
I also have a table for dates
Is it even worth contemplating to solve this in Powerpivot, because it seems quite daunting to me atm.




<TBODY>

</TBODY>


----------



## Laurent C (Sep 26, 2012)

bertusavius said:


> @mr C:
> interesting approach. As long as the intervals are small and there are many events per hour, the averages work quite well.
> But I'm affraid they're not accurate enough.
> 
> I'd like the cumulative values of the buckets to be as close as or equal to the real trip data.



I did not mean using an average, but using a calculated table within a SUMX function. I used linear extrapolation for the calculation, but you could use some more elaborate formula, if required.

If you have an event that spans over 3 time buckets, then you would have 3 rows in your calculated table, each with its extrapolated values for tripstart and tripstop.


----------



## b.downey (Sep 26, 2012)

The Bin Data provided is not cummulative from One Bin two the Next (One hour to the next).... The Data in each bin is prorated for that Bin.

Here is the results of the data from your example.

As you see, the data from 8:00 AM to 8:59 AM (19.5) is less that that from the 7-8 AM hour (119.5)

Am I missing something


ID</SPAN>BIN</SPAN> Distance Traveled </SPAN>25</SPAN>6</SPAN>                            1.7 </SPAN>25</SPAN>7</SPAN>                        119.3 </SPAN>25</SPAN>8</SPAN>                          19.5 </SPAN>25</SPAN>9</SPAN>                            9.5 </SPAN>

<TBODY>

</TBODY><COLGROUP><COL span=2><COL></COLGROUP>


----------



## bertusavius (Sep 26, 2012)

Sorry for the delay.
I tested both your solutions. 
They come up with exactly the same results.

If I use it on this different data for instance:

ABCD32TX startTX stopINS_KILOMETERSTANDUIT_KILOMETERSTAND3315:1815:23272690272692
3415:1515:592726902727123515:3315:442726982727053615:3315:472726982727063716:1616:252727162727183816:3816:472727202727243916:5216:572727252727284016:2016:372727162727204116:5917:122727282727314217:3117:322727342727344317:2417:312727312727344417:4417:562727372727424517:3718:052727352727454618:5419:192727622727714718:2519:102727512727684818:1318:182727472727484918:5019:492727612727945018:2118:382727492727555119:0219:152727632727705220:1520:312728112728215320:4420:512728322728345421:3421:402728362728395521:4021:472728392728415622:0022:24272850272868

<tbody>

</tbody>*Blad1*​this is table 'data' 

with this table 'buckets'


AEF35BucketIDStart tijdEind tijd3620003000-01-00 2:000-01-00 3:003730004000-01-00 3:000-01-00 4:003840005000-01-00 4:000-01-00 5:003950006000-01-00 5:000-01-00 6:004060007000-01-00 6:000-01-00 7:004170008000-01-00 7:000-01-00 8:004280009000-01-00 8:000-01-00 9:004390010000-01-00 9:000-01-00 10:0044100011000-01-00 10:000-01-00 11:0045110012000-01-00 11:000-01-00 12:0046120013000-01-00 12:000-01-00 13:0047130014000-01-00 13:000-01-00 14:0048140015000-01-00 14:000-01-00 15:0049150016000-01-00 15:000-01-00 16:0050160017000-01-00 16:000-01-00 17:0051170018000-01-00 17:000-01-00 18:0052180019000-01-00 18:000-01-00 19:0053190020000-01-00 19:000-01-00 20:0054200021000-01-00 20:000-01-00 21:0055210022000-01-00 21:000-01-00 22:0056220023000-01-00 22:000-01-00 23:0057230024000-01-00 23:000-01-00 0:0058240025000-01-00 0:000-01-00 1:0059250026000-01-00 1:000-01-00 2:006024002500

<tbody>

</tbody>*Blad2*​
Als using a calculated column estimated speed
=([UIT_KILOMETERSTAND]-[INS_KILOMETERSTAND])/(([TX stop]-[TX start])*24)


with a measure: 
SUMX(
      CROSSJOIN('data';'buckets');
      IF(AND('data'[TX start] < 'buckets'[Eind tijd] ; 'data'[TX stop] > 'buckets'[Start tijd]) 
               ; if('buckets'[Eind tijd] > data[TX stop] ; data[TX stop]; 'buckets'[Eind tijd]) 
                 - 
                 if('buckets'[Start tijd] < 'data'[TX start];'data'[TX start];'buckets'[Start tijd])
               ;0)*24*data[estimatedspeed])


I get this result:

ST15RijlabelsMeting 116200030017300040018400050019500060020600070021700080022800090023900100024100011002511001200261200130027130014002814001500291500160039,00301600170013,23311700180018,98321800190029,76331900200045,02342000210012,0035210022005,00362200230018,0037230024003824002500392500260040Eindtotaal181,00

<colgroup><col style="width: 25pxpx"><col><col></colgroup><thead>

</thead><tbody>

</tbody>*Blad3*​
The result is a perfectly round number which deviates (181/178)%
Also the numbers in the buckets don't really seem to correspond with reality.


----------



## b.downey (Sep 26, 2012)

Are you all set? Or do you need some additional assistance?


----------



## bertusavius (Sep 26, 2012)

I'm affraid I'm not entirely set.
As you compare the data with the result, you see the bins do not acurately represent the actual driven miles per hour. Perhaps the Average speed could be more acurately calculated.

I'll be back tomorrow. Thank you for your swift replies.


----------



## b.downey (Sep 26, 2012)

Oh...   I was not aware that you were looking for a miles per hour (speed) calculation.   I was look at it as the number of total miles traveled in each bin (hour)...  Clearly two entirely different calculation!

let me take another look at the post and solutions.

also, for the sample data you provide, could you provide the number you would like to see in each bin.  This would be a tremendous help


----------



## b.downey (Sep 26, 2012)

I am still not real clear on your requirments, but Here is another shoot at the issue... The Code below provides
-The Miles Traveled in each hour (Bin)
-The Time of actual travel in each hour (Bin)
-The KmPH (Average)


```
Option Explicit
Type typRec
    ID As Integer
    BinArray(24) As Double
    BinMins(24) As Long
End Type
Sub Calc()
    Dim Rec() As typRec
    ReDim Rec(0)
    Dim ws As Worksheet
    
    Dim RowNo As Long
    
    Dim StartTime As Date
    Dim EndTime As Date
    
    Dim IdIdx As Integer
    Dim BinIdx As Integer
    Dim HourCnt As Integer
    Dim Miles As Long
    
    Dim TotalMin As Long
    Dim Min As Integer
    
    Dim Perc As Single
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    RowNo = 2
    For RowNo = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        IdIdx = FindIdx(ws.Cells(RowNo, 1), Rec)
        StartTime = ws.Cells(RowNo, 2)
        EndTime = ws.Cells(RowNo, 3)
        Miles = ws.Cells(RowNo, 5) - ws.Cells(RowNo, 4)
        HourCnt = Hour(EndTime) - Hour(StartTime)
        
        Select Case HourCnt
            Case 0
                BinIdx = Hour(StartTime)
                TotalMin = DateDiff("n", StartTime, EndTime)
                Rec(IdIdx).BinArray(BinIdx) = Rec(IdIdx).BinArray(BinIdx) + Miles
                Rec(IdIdx).BinMins(BinIdx) = Rec(IdIdx).BinMins(BinIdx) + TotalMin
            Case Is > 0
                TotalMin = DateDiff("n", StartTime, EndTime)
                '***** Determine fractional time for 1st hour
                BinIdx = Hour(StartTime)
                Min = DateDiff("n", StartTime, CDate(BinIdx + 1 & ":00:00"))
                Perc = Min / TotalMin
                Rec(IdIdx).BinArray(BinIdx) = Rec(IdIdx).BinArray(BinIdx) + (Miles * Perc)
                Rec(IdIdx).BinMins(BinIdx) = Rec(IdIdx).BinMins(BinIdx) + Min
                
                Perc = 60 / TotalMin
                For BinIdx = Hour(StartTime) + 1 To Hour(EndTime) - 1
                    Rec(IdIdx).BinArray(BinIdx) = Rec(IdIdx).BinArray(BinIdx) + (Miles * Perc)
                    Rec(IdIdx).BinMins(BinIdx) = Rec(IdIdx).BinMins(BinIdx)
                Next BinIdx
                
                '***** Determine fractional time for Last hour
                BinIdx = Hour(EndTime)
                Min = DateDiff("n", CDate(BinIdx & ":00:00"), EndTime)
                Perc = Min / TotalMin
                Rec(IdIdx).BinArray(BinIdx) = Rec(IdIdx).BinArray(BinIdx) + (Miles * Perc)
                Rec(IdIdx).BinMins(BinIdx) = Rec(IdIdx).BinMins(BinIdx) + Min
            Case Else
    
        End Select
    Next RowNo
    
Call OutputResults(Rec)
End Sub
Function OutputResults(Rec() As typRec)
    Dim I As Integer
    Dim BinIdx As Integer
    Dim ws As Worksheet
    Dim RowNo As Long
    
    Set ws = ThisWorkbook.Worksheets("Sheet2")
    ws.Cells.ClearContents
    
    ws.Cells(1, "A") = "ID"
    ws.Cells(1, "B") = "Bin (Hour)"
    ws.Cells(1, "C") = "Miles Traveled"
    ws.Cells(1, "D") = "Minutes"
    ws.Cells(1, "E") = "KmPH"
    
    RowNo = 2
    For I = 1 To UBound(Rec)
        For BinIdx = 1 To 24
            If Rec(I).BinArray(BinIdx) > 0 Then
                ws.Cells(RowNo, 1) = Rec(I).ID
                ws.Cells(RowNo, 2) = BinIdx & ":00 - " & (BinIdx + 1) & ":00"
                ws.Cells(RowNo, 3) = Format(Rec(I).BinArray(BinIdx), "0.00")
                ws.Cells(RowNo, 4) = Rec(I).BinMins(BinIdx)
                ws.Cells(RowNo, 5) = Format(Rec(I).BinArray(BinIdx) / Rec(I).BinMins(BinIdx) * 60, "0.00")
                RowNo = RowNo + 1
            End If
        Next BinIdx
    Next I
    
    ws.Rows("1:1").WrapText = True
    ws.Columns("C:C").Style = "Comma"
    ws.Columns("E:E").Style = "Comma"
End Function
Function FindIdx(ID As Integer, Rec() As typRec) As Integer
    Dim I As Integer
    
    For I = 1 To UBound(Rec)
        If Rec(I).ID = ID Then
            FindIdx = I
            Exit Function
        End If
    Next I
    
    ReDim Preserve Rec(I)
    Rec(I).ID = ID
    FindIdx = I
    
End Function
```


Based on the Data in your most recent post, the code creates the following 


ID</SPAN>Bin (Hour)</SPAN> Miles Traveled </SPAN>Minutes</SPAN> KmPH </SPAN>1</SPAN>15:00 - 16:00</SPAN>        39.00 </SPAN>74</SPAN>        31.62 </SPAN>1</SPAN>16:00 - 17:00</SPAN>        13.23 </SPAN>41</SPAN>        19.36 </SPAN>1</SPAN>17:00 - 18:00</SPAN>        18.98 </SPAN>55</SPAN>        20.71 </SPAN>1</SPAN>18:00 - 19:00</SPAN>        29.76 </SPAN>78</SPAN>        22.89 </SPAN>1</SPAN>19:00 - 20:00</SPAN>        45.02 </SPAN>91</SPAN>        29.69 </SPAN>1</SPAN>20:00 - 21:00</SPAN>        12.00 </SPAN>23</SPAN>        31.30 </SPAN>1</SPAN>21:00 - 22:00</SPAN>          5.00 </SPAN>13</SPAN>        23.08 </SPAN>1</SPAN>22:00 - 23:00</SPAN>        18.00 </SPAN>24</SPAN>        45.00 </SPAN>

<TBODY>

</TBODY><COLGROUP><COL><COL><COL><COL><COL></COLGROUP>


----------



## b.downey (Oct 3, 2012)

```
Option Explicit
Const DateCol As Integer = 1
Const StartTimeCol As Integer = 2
Const EndTimeCol As Integer = 3
Const CarNoCol As Integer = 5
Const StartMileCol As Integer = 6
Const EndMileCol As Integer = 7
Type typRawRec
    t As Date
    mile As Long
End Type
Type typCar
    CarNo As Integer
    rec() As typRawRec
End Type
Type typDT
    trvlDate As String
    Car() As typCar
End Type
    
Sub Process()
    Dim ws As Worksheet
    Dim arrDt() As typDT
    
    Dim RowNo As Long
    Dim LastRow As Long
    
    Dim StartTime As Date
    Dim Idx As Long
    Dim I As Long
    
    Dim DtIdx As Integer
    Dim CarIdx As Integer
    
    Set ws = ThisWorkbook.Worksheets(1)
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ReDim arrDt(0)
    ReDim arrDt(0).Car(0)
    ReDim arrDt(0).Car(0).rec(0)
    
    For RowNo = 2 To LastRow
        If Len(Trim(ws.Cells(RowNo, StartTimeCol))) > 1 Then
            
            DtIdx = FindDtIdx(ws.Cells(RowNo, DateCol), arrDt)
            CarIdx = FindCarIdx(ws.Cells(RowNo, CarNoCol), arrDt(DtIdx).Car)
            Idx = UBound(arrDt(DtIdx).Car(CarIdx).rec)
            
            ReDim Preserve arrDt(DtIdx).Car(CarIdx).rec(Idx + 2)
            Idx = Idx + 1
            arrDt(DtIdx).Car(CarIdx).rec(Idx).t = CDate(ws.Cells(RowNo, StartTimeCol))
            arrDt(DtIdx).Car(CarIdx).rec(Idx).mile = Val(ws.Cells(RowNo, StartMileCol))
            Call InsertRec(arrDt(DtIdx).Car(CarIdx).rec, Idx)
            
            Idx = Idx + 1
            'rec(Idx).Id = Val(ws.Cells(RowNo, 1))
            arrDt(DtIdx).Car(CarIdx).rec(Idx).t = CDate(ws.Cells(RowNo, EndTimeCol))
            arrDt(DtIdx).Car(CarIdx).rec(Idx).mile = Val(ws.Cells(RowNo, EndMileCol))
            Call InsertRec(arrDt(DtIdx).Car(CarIdx).rec, Idx)
        End If
    Next RowNo
    
    Call OutputAll(arrDt)
    
    MsgBox "Complete", vbInformation
End Sub
Function OutputAll(arrDt() As typDT)
    Dim ws As Worksheet
    Dim RowNo  As Integer
    Dim DtIdx As Integer
    
    Dim CarIdx As Integer
    
    Set ws = ThisWorkbook.Worksheets(2)
    ws.Cells.ClearContents
    RowNo = 1
    
    ws.Cells(RowNo, 1) = "Date"
    ws.Cells(RowNo, 2) = "Car"
    ws.Cells(RowNo, 3) = "Bucket"
    ws.Cells(RowNo, 4) = "Kms"
            
    For DtIdx = 1 To UBound(arrDt)
        For CarIdx = 1 To UBound(arrDt(DtIdx).Car)
            Call OutputData(ws, arrDt(DtIdx).Car(CarIdx).rec, arrDt(DtIdx).trvlDate, arrDt(DtIdx).Car(CarIdx).CarNo)
        Next CarIdx
    Next DtIdx
End Function
Function OutputData(ws As Worksheet, rec() As typRawRec, Dt As String, CarNo As Integer)
    Dim I As Integer
    Dim RowNo As Long
    
    Dim StartTime As Date
    Dim StartMiles As Long
    
    Dim ElapsedMin   As Long
    Dim ElapsedMiles   As Long
    
    Dim Perc As Single
    Dim Min As Integer
    
    StartTime = rec(1).t
    StartMiles = rec(1).mile
    
    Dim Car(0) As typCar
    RowNo = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row + 1
    
    For I = 2 To UBound(rec)
        
        If Hour(StartTime) <> Hour(rec(I).t) Then
            ElapsedMin = DateDiff("n", rec(I - 1).t, rec(I).t)
            ElapsedMiles = rec(I).mile - rec(I - 1).mile
            
            '----- Need to Adjust Bins
            '***** Determine Offset Percentage
            Min = DateDiff("n", rec(I - 1).t, CDate(Hour(rec(I - 1).t) + 1 & ":00:00"))
            Perc = Min / ElapsedMin
            
            '***** Apply Offset
            rec(I - 1).mile = rec(I - 1).mile + ElapsedMiles * Perc
            rec(I).mile = rec(I).mile - ElapsedMiles * (1 - Perc)
            
            '***** Output Data
            ws.Cells(RowNo, 1) = Dt
            ws.Cells(RowNo, 2) = CarNo
            ws.Cells(RowNo, 3) = Hour(StartTime) & ":00" & " ~ " & (Hour(StartTime) + 1) & ":00"
            ws.Cells(RowNo, 4) = rec(I - 1).mile - StartMiles
            
            '***** Reset start time and miles
            StartTime = rec(I).t
            StartMiles = rec(I).mile
            RowNo = RowNo + 1
            I = I + 1
        End If
    Next I
    
    Debug.Print CarNo, UBound(rec)
    
    ws.Cells(RowNo, 1) = Dt
    ws.Cells(RowNo, 2) = CarNo
    ws.Cells(RowNo, 3) = Hour(StartTime) & ":00" & " ~ " & (Hour(StartTime) + 1) & ":00"
    ws.Cells(RowNo, 4) = rec(I - 1).mile - StartMiles
            
End Function
Function InsertRec(arrRec() As typRawRec, Idx As Long)
    Dim I As Integer
    Dim xRec As typRawRec
    
    '*****  This function sorts the last record into the correct location
    For I = Idx - 1 To 1 Step -1
        If arrRec(I).t > arrRec(I + 1).t Then
            xRec = arrRec(I + 1)
            arrRec(I + 1) = arrRec(I)
            arrRec(I) = xRec
        Else
            Exit Function
        End If
    Next I
End Function
Function FindCarIdx(ByVal CarNo As Integer, Car() As typCar) As Integer
    Dim I As Integer
    
    For I = 1 To UBound(Car)
        If CarNo = Car(I).CarNo Then
            FindCarIdx = I
            Exit Function
        End If
    Next I
    
    ReDim Preserve Car(I)
    Car(I).CarNo = CarNo
    
    ReDim Car(I).rec(0)
    
    FindCarIdx = I
End Function
Function FindDtIdx(ByVal Dt As Date, arrDt() As typDT) As Integer
    Dim I As Integer
    
    For I = 1 To UBound(arrDt)
        If Dt = arrDt(I).trvlDate Then
            FindDtIdx = I
            Exit Function
        End If
    Next I
    
    ReDim Preserve arrDt(I)
    arrDt(I).trvlDate = Dt
 
    ReDim arrDt(I).Car(0)
    ReDim arrDt(I).Car(0).rec(0)
    
    FindDtIdx = I
End Function
```


----------



## b.downey (Oct 4, 2012)

This version of the code accounts for the new columns that you added. It will also be able to to the calculations seperating the data by Date, Driver, Car and Bin.


```
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
```


----------



## bertusavius (Oct 5, 2012)

Fantastic!
It works really well

Just having a very minor issue with the dates:
The database uses d/m/y layout for a date, but your macro transforms the dates into m/d/y. (which naturally causes an error as soon as the day exceeds 12)


----------



## bertusavius (Sep 24, 2012)

I have a table with a list of events that have ID, two time-values and two 'trip values'.




*ID*
*Timestart*
*Timestop*
*tripstart*
*tripstop*
25
6:55
7:55
259010
259030
25
7:06
7:55
259011
259030
25
7:11
7:57
259013
259030
25
7:17
7:57
259014
259030
25
7:23
7:57
259015
259030
25
7:27
7:59
259017
259031
25
7:29
7:58
259017
259031
25
7:40
7:59
259025
259031
25
8:11
8:21
259038
259043
25
8:41
9:07
259049
259063
25
8:48
9:16
259054
259064
78
13:24
13:34
259116
259122
78
13:40
14:14
259122
259134
78
13:45
14:22
259124
259136
78
13:54
14:22
259127
259136
78
14:03
14:23
259130
259136
78
14:35
14:58
259144
259148
78
14:36
14:58
259144
259148
78
14:43
15:06
259145
259150
78
14:52
15:38
259146
259162
78
15:19
15:42
259155
259163
78
15:27
15:47
259157
259164
78
15:54
16:02
259165
259167


<TBODY>

</TBODY>

<TBODY>

</TBODY>


To make things less abstract:
The trip-value is the value of a trip meter in a car in kilometers.
So the top record actualy says:
car nr 25 had an event that started at 06:55 at trip value 259010 and this event stopped at 07:55 coinciding with trip value 259030
You could say this is a list of events with corresponding accumulating properties, so wether the timeID starts or stops doesnt really matter. All the matters is that a certain time corresponds with a certain trip value.





Now wat I'd like is to create a measure that transforms and divides this information like this:




*ID*
*binID*
*distance travelled*
25
0700-0800
(value in kms)
25
0800-0900
(value in kms)
25
0900-1000
(value in kms)
78
0700-0800
(value in kms)
78
0800-0900
(value in kms)
78
0900-1000
(value in kms)


<TBODY>

</TBODY>

<TBODY>

</TBODY>



<TBODY>

</TBODY>
I have a table to relate to which contains binID, binstart and binstop
I also have a table for dates
Is it even worth contemplating to solve this in Powerpivot, because it seems quite daunting to me atm.




<TBODY>

</TBODY>


----------



## b.downey (Oct 6, 2012)

In the Control Panel "Region and Language" settings, what do you have set for "Format" ?


----------



## bertusavius (Oct 7, 2012)




----------



## bertusavius (Oct 7, 2012)

As soon as I expand the dataset, I'm affraid I'm getting an error in this part of the code:

ws.Cells(RowNo, 4) = rec(I - 1).mile - StartMiles

<tbody>

</tbody>
Can you confirm that with this ie example:


DatumTX startTX stopChWP_WAGEN_NUMMERINS_KILOMETERSTANDUIT_KILOMETERSTAND3-4-20126:146:235213431683001683063-4-20126:096:165213431682981683013-4-20127:318:235357254836824837053-4-20128:208:235357254837044837053-4-20127:318:235357254836824837053-4-20127:318:235357254836824837053-4-20126:418:235357254836604837053-4-20126:577:265213431683111683273-4-20127:077:345213431683131683303-4-20127:027:145213431683121683163-4-20128:058:265213431683451683533-4-20128:408:405357254837154837163-4-20129:019:255357254837324837533-4-20129:289:455213431683731683883-4-201210:0010:075213431683931683963-4-201210:2510:465213431684041684113-4-201210:3510:495213431684081684113-4-201210:4010:585213431684081684143-4-201211:3411:515213431684241684313-4-201211:3511:515213431684241684313-4-201211:4211:565213431684271684333-4-201211:1511:465213431684181684293-4-201211:0611:295213431684161684233-4-201211:5712:325357254837714837893-4-201211:5712:265357254837714837863-4-201211:5712:285357254837714837873-4-201213:2213:405213431684561684633-4-201213:2313:315213431684561684583-4-201212:5613:225357254837994838293-4-201214:2914:575357254838294838623-4-201212:5513:255213431684481684563-4-201213:5014:065213431684651684683-4-201213:5814:135213431684661684703-4-201214:3414:435213431684751684783-4-201214:2314:565213431684721684813-4-201214:3115:025213431684741684843-4-201214:3315:025213431684751684843-4-201215:5316:025213431684981685043-4-201215:3516:045213431684931685053-4-20125213433-4-201215:2115:245213431684891684903-4-201215:3015:50535725483872483880

<tbody>

</tbody>


----------



## b.downey (Oct 7, 2012)

You must be using some all code. The Current code does not have the line you listed your previous post (#23).

In any event, the code reads in the Dates as "String" (and transforms it to a "Variant") rather than "Dates" so I am not sure why it is not providing the information of the second (results) sheet properly... 


In any event, I have made a change to the code to expressly change the the Date from a "variant" to a Date


```
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
    MsgBox "Complete", vbInformation
    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) >= 2 Then
                ws.Cells(RowNo, 1) = CDate(v(0))
                ws.Cells(RowNo, 2) = v(1)
                ws.Cells(RowNo, 3) = v(2)
            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
```


----------



## bertusavius (Oct 7, 2012)

Amazing how flawless and fast this script works.
It just ran through 20K lines in mere seconds.



Please do say so if you feel I'm over-asking here, but observing the output, I realize there is still another dimension to his problem.

If you process for instance this data:


DatumTX startTX stopChWP_WAGEN_NUMMERINS_KILOMETERSTANDUIT_KILOMETERSTAND12-3-201216:30:0023:45:005207122735022750012-3-201216:36:0017:39:005207122735422737912-3-201216:36:0017:35:005207122735422737812-3-201216:53:0017:15:005207122735622736712-3-201216:59:0017:29:005207122735722737612-3-201217:57:0018:18:005207122738622739412-3-201218:11:0018:30:005207122739122740012-3-201218:21:0018:33:005207122739422740012-3-201218:39:0018:50:005207122740122740412-3-201218:43:0019:30:005207122740222742212-3-201219:00:0019:35:005207122740822742512-3-201219:11:0019:36:005207122741522742512-3-201219:20:0019:49:005207122741822743312-3-201221:29:0021:37:005207122744022744212-3-201221:51:0022:14:005207122744922745912-3-201222:01:0022:19:005207122745322746012-3-201223:20:0023:38:0052071227473227492

<tbody>

</tbody>
You will see that between 20:00 and 21:00 hour, no event was started or stopped.
This results of course in the fact that the code doesnt generate a time-bucket for 20:00-21:00.
However in this time-spam, 7 kilometers were travelled.

Can the code be modified even further to provide for this problem?
I realise this might result in an exponential growth in the amount of lines generated. 
Also which driver ID should be associated?
Many other questions will certanly arise as well. 


Perhaps something else would be helpful.
I happen to have another table which contains start and stop events of shifts, with associated time and mileage values.
These shifts encompass, contain, so to say, all the events which are in my original data. So within a shift, things happen a certain time and mileage values. 

I have added such a line of data in the above example. (top line)
You see this line has the earliest start-time and the latest stop-time, as well as the lowest and the highest mileage value.


So the above in one sentence:
Do you think it might also be possible to let the script recognise the fact  that (in the above example) it should also create the 20:00-21:00 line?


----------



## b.downey (Oct 8, 2012)

Do you expect the Data do be in excess of one calandar day


----------



## bertusavius (Oct 8, 2012)

Yes,

The data usually consists of many days, say a month.

Also shifts might run after midnight and events can also start before midnight and end after midnight.

Pretty complicated.


----------



## b.downey (Oct 8, 2012)

If I look at the original data, You have one column for a Date and two columns for Times (One for Start Time and another for End Time) How do you represent a Event that start before mid night and ends the next day?

Here is some code that display the 4 miles incured during the 20:00 to 21:00 bin.   The end result is still 150 miles


```
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
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
    
    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, DateCol)) & "~" & 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 = ws.Cells(RowNo, StartTimeCol)
            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 = ws.Cells(RowNo, EndTimeCol)
            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 MilesInHr(24) As Long
    
    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)
            StartHr = Hour(MstRec.DT_Miles(I - 1).Dt)
            EndHr = Hour(MstRec.DT_Miles(I).Dt)
            HourDiff = EndHr - StartHr
            
            Select Case HourDiff
                Case 0
                    MilesInHr(StartHr) = MilesInHr(StartHr) + ElapsedMiles
                Case Else
                    '***** Determine fractional time for 1st hour
                    BinIdx = Hour(StartTime)
                    tempMins = DateDiff("n", StartTime, CDate(BinIdx + 1 & ":00:00"))
                    Perc = tempMins / ElapsedMins
                    MilesInHr(BinIdx) = MilesInHr(BinIdx) + (ElapsedMiles * Perc)
                
                    Perc = 60 / ElapsedMins
                    For BinIdx = Hour(StartTime) + 1 To Hour(EndTime) - 1
                        MilesInHr(BinIdx) = MilesInHr(BinIdx) + (ElapsedMiles * Perc)
                    Next BinIdx
                    
                    '***** Determine fractional time for Last hour
                    BinIdx = Hour(EndTime)
                    tempMins = DateDiff("n", CDate(BinIdx & ":00:00"), EndTime)
                    Perc = tempMins / ElapsedMins
                    MilesInHr(BinIdx) = MilesInHr(BinIdx) + (ElapsedMiles * Perc)
            End Select
        End If
    Next I
       
    v = Split(Key, "~")
    For I = 1 To 24
        If MilesInHr(I) > 0 Then
            ws.Cells(RowNo, 1) = CDate(v(0))
            ws.Cells(RowNo, 2) = v(1)
            ws.Cells(RowNo, 3) = v(2)
            ws.Cells(RowNo, 4) = I & ":00" & " ~ " & (I + 1) & ":00"
            ws.Cells(RowNo, "E") = MilesInHr(I)
            RowNo = RowNo + 1
        End If
    Next 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
```


----------



## bertusavius (Oct 8, 2012)

This is utterly briliant:
I will have to run some more data through the code, but so far the output is even more accurate then I would have hoped.


The date column is linked to the start time.
So if an event crosses midnight. The data associated with the stop time should be date+1.

A solution I used earlier in non vba approaches:
The rest of the data of the larger model works with time buckets that exceed midnight. So things that happen between 2400 and 0100 are in a bucket called '2400-2500'. Also the bucket 2500-2600 exists. 
After that the next one is 0200-0300. Events that cross 2600 hour are extremely rare. 

So in the PowerPivot model, I'll be relating the output to this "bucket-table":


0200-03000300-04000400-05000500-06000600-07000700-08000800-09000900-10001000-11001100-12001200-13001300-14001400-15001500-16001600-17001700-18001800-19001900-20002000-21002100-22002200-23002300-24002400-25002500-2600

<tbody>

</tbody>


----------



## b.downey (Oct 8, 2012)

Ok... Here is some improvement to the last version

If the Endtime < Starttime on the Source sheet, the application will assume that the endtime is the folloiwng day (Date listed in Col 1 + 1)

The Code will handle Date Transition correctly because it does all calulation of the combination of Date & Time rather than time alone. 

All Dates and Times must be valid

Depending of the number of miles, there cound be some rounding errors becouse we are using whole (integer) rather than fractional numbers.   Depending on you data, it may make since to fo with fractional miles
Let me know how this works for you




```
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
```


----------



## bertusavius (Sep 24, 2012)

I have a table with a list of events that have ID, two time-values and two 'trip values'.




*ID*
*Timestart*
*Timestop*
*tripstart*
*tripstop*
25
6:55
7:55
259010
259030
25
7:06
7:55
259011
259030
25
7:11
7:57
259013
259030
25
7:17
7:57
259014
259030
25
7:23
7:57
259015
259030
25
7:27
7:59
259017
259031
25
7:29
7:58
259017
259031
25
7:40
7:59
259025
259031
25
8:11
8:21
259038
259043
25
8:41
9:07
259049
259063
25
8:48
9:16
259054
259064
78
13:24
13:34
259116
259122
78
13:40
14:14
259122
259134
78
13:45
14:22
259124
259136
78
13:54
14:22
259127
259136
78
14:03
14:23
259130
259136
78
14:35
14:58
259144
259148
78
14:36
14:58
259144
259148
78
14:43
15:06
259145
259150
78
14:52
15:38
259146
259162
78
15:19
15:42
259155
259163
78
15:27
15:47
259157
259164
78
15:54
16:02
259165
259167


<TBODY>

</TBODY>

<TBODY>

</TBODY>


To make things less abstract:
The trip-value is the value of a trip meter in a car in kilometers.
So the top record actualy says:
car nr 25 had an event that started at 06:55 at trip value 259010 and this event stopped at 07:55 coinciding with trip value 259030
You could say this is a list of events with corresponding accumulating properties, so wether the timeID starts or stops doesnt really matter. All the matters is that a certain time corresponds with a certain trip value.





Now wat I'd like is to create a measure that transforms and divides this information like this:




*ID*
*binID*
*distance travelled*
25
0700-0800
(value in kms)
25
0800-0900
(value in kms)
25
0900-1000
(value in kms)
78
0700-0800
(value in kms)
78
0800-0900
(value in kms)
78
0900-1000
(value in kms)


<TBODY>

</TBODY>

<TBODY>

</TBODY>



<TBODY>

</TBODY>
I have a table to relate to which contains binID, binstart and binstop
I also have a table for dates
Is it even worth contemplating to solve this in Powerpivot, because it seems quite daunting to me atm.




<TBODY>

</TBODY>


----------



## bertusavius (Oct 10, 2012)

I'm running your code very succesfully on my data.

But would you mind taking a look at this data:


*Datum*
*TX start*
*TX stop*
*Ch*
*WP_WAGEN_NUMMER*
*INS_KILOMETERSTAND*
*UIT_KILOMETERSTAND*
5-3-2012
7:31:00
8:32:00
1006
1
225421
225447
5-3-2012
7:42
8:20
1006
1
225423
225440
5-3-2012
7:49
8:20
1006
1
225426
225440
5-3-2012
7:54
8:20
1006
1
225428
225440
5-3-2012
8:20
8:20
1006
1
225440
225440
5-3-2012
9:07:00
10:43:00
53
1
225447
225564
5-3-2012
9:16
10:02
53
1
225451
225509
5-3-2012
15:00:00
15:50:00
1006
1
225564
225591
5-3-2012
15:12
15:36
1006
1
225572
225586
5-3-2012
15:12
15:30
1006
1
225572
225584
5-3-2012
15:12
15:27
1006
1
225572
225582
5-3-2012
15:12
15:42
1006
1
225572
225588


<TBODY>

</TBODY>

It seems that two overlapping shifts occur in the output, so the mileages add up while they shouldnt.


----------



## b.downey (Oct 10, 2012)

The Code I develope does not look at "Shifts" for each car.... Instead it looks at the Time and the respective mileage at that time for each car.

Here is a different represetation of the data you provided for Car 1006



Date</SPAN>Miles </SPAN>Differenc</SPAN>5/3/2012 7:31</SPAN>225421</SPAN> 5/3/2012 7:42</SPAN>225423</SPAN>2</SPAN>5/3/2012 7:49</SPAN>225426</SPAN>3</SPAN>5/3/2012 7:54</SPAN>225428</SPAN>2</SPAN>5/3/2012 8:20</SPAN>225440</SPAN>12</SPAN>5/3/2012 8:20</SPAN>225440</SPAN>0</SPAN>5/3/2012 8:20</SPAN>225440</SPAN>0</SPAN>5/3/2012 8:20</SPAN>225440</SPAN>0</SPAN>5/3/2012 8:20</SPAN>225440</SPAN>0</SPAN>5/3/2012 8:32</SPAN>225447</SPAN>7</SPAN>5/3/2012 15:00</SPAN>225564</SPAN>117</SPAN>5/3/2012 15:12</SPAN>225572</SPAN>8</SPAN>5/3/2012 15:12</SPAN>225572</SPAN>0</SPAN>5/3/2012 15:12</SPAN>225572</SPAN>0</SPAN>5/3/2012 15:12</SPAN>225572</SPAN>0</SPAN>5/3/2012 15:27</SPAN>225582</SPAN>10</SPAN>5/3/2012 15:30</SPAN>225584</SPAN>2</SPAN>5/3/2012 15:36</SPAN>225586</SPAN>2</SPAN>5/3/2012 15:42</SPAN>225588</SPAN>2</SPAN>5/3/2012 15:50</SPAN>225591</SPAN>3</SPAN>Total</SPAN>170</SPAN>

<TBODY>

</TBODY><COLGROUP><COL><COL span=2></COLGROUP>

I am using the Difference (Column C) to do the Calculations....     Based on my understanding of your requirement, The 'Shift' Really does not have anything to do with the calculation, it's really a snap shot of miles at a specific time that matters.

Am I missing something?


----------



## bertusavius (Oct 10, 2012)

I think I understand what your method of mileage calculation per hour is, but in the output you seem to correctly relate this to car and driver ID. However, sometimes this relation doenst work like in the above example.

I'm really looking for an absolute relation between mileage-carID-DriverID.

BTW: Are you aware that value 1006 represents a driver ID (not car)?

This would be an explanation of the data:


datestarteventstopeventDRIVERCARstartmileagestopmileageDatumTX startTX stopChWP_WAGEN_NUMMERINS_KILOMETERSTANDUIT_KILOMETERSTAND5-3-20127:31:008:32:0010061225421225447Driver 1006 starts his shift in car 1 at 07:31 and stops his shift at 08:32 with associated mileages5-3-20127:428:20100612254232254405-3-20127:498:20100612254262254405-3-20127:548:2010061225428225440Driver 1006 starts a job at 07:54 and stops at at 08:20 with associated mileages5-3-20128:208:20100612254402254405-3-20129:07:0010:43:00531225447225564Driver 53 starts his shift in car 1 at 09:07  and stops his shift at 10:43 with associated mileages5-3-20129:1610:02531225451225509Driver 53 starts a job at 9:16 and stops it at 10:02 with associated mileages5-3-201215:00:0015:50:00100612255642255915-3-201215:1215:36100612255722255865-3-201215:1215:30100612255722255845-3-201215:1215:27100612255722255825-3-201215:1215:4210061225572225588

<tbody>

</tbody>

When you use this next piece data data for example, you see that only in the first hour there is no 'overlap':


DatumTX startTX stopChWP_WAGEN_NUMMERINS_KILOMETERSTANDUIT_KILOMETERSTAND1-3-20128:25:0012:55:00500422000632003531-3-20128:419:16500422000772001061-3-20128:539:05500422000872000971-3-20128:589:13500422000912001031-3-20129:0010:12500422000942001701-3-20129:009:36500422000942001271-3-20129:049:28500422000962001191-3-20129:099:21500422000982001101-3-20129:209:28500422001092001191-3-20129:3610:02500422001272001601-3-20129:4010:19500422001302001811-3-20129:4010:19500422001302001821-3-20129:489:58500422001362001551-3-201210:1210:38500422001702002081-3-201210:1210:40500422001702002081-3-201210:3010:41500422001952002081-3-201210:4710:53500422002102002161-3-201210:5911:17500422002172002541-3-201211:4211:53500422002962003071-3-201211:4211:54500422002962003071-3-201211:4312:39500422002962003401-3-201211:4912:20500422003042003301-3-201212:0912:30500422003182003361-3-201212:1912:33500422003302003381-3-201212:58:0021:54:00533622003532009591-3-201213:1813:23533622003782003831-3-201213:2913:42533622003832003881-3-201213:2913:42533622003832003881-3-201213:2913:42533622003832003881-3-201213:3013:42533622003832003881-3-201213:5314:17533622003982004371-3-201214:0314:23533622004132004451-3-201214:0414:23533622004132004451-3-201214:3915:08533622004612005061-3-201214:4815:01533622004702005001-3-201215:0615:29533622005042005241-3-201215:1215:22533622005072005111-3-201215:2215:37533622005112005351-3-201216:2916:43533622005602005751-3-201216:5517:16533622005802006411-3-201217:1617:30533622006412006711-3-201217:5217:58533622006842006901-3-201218:1918:47533622007312007671-3-201218:3119:16533622007462007971-3-201218:4418:54533622007642007771-3-201219:0919:20533622007902008011-3-201219:0919:21533622007902008031-3-201220:0420:18533622008212008411-3-201220:2720:40533622008492008801-3-201220:5721:21533622009012009241-3-201220:5721:21533622009012009241-3-201220:5721:21533622009012009241-3-201220:5721:22533622009012009251-3-201220:5721:21533622009012009241-3-201220:5821:22533622009012009251-3-201220:5821:22533622009012009251-3-201221:0421:1053362200904200913

<tbody>

</tbody>


----------



## b.downey (Oct 10, 2012)

Very interesting.   I understand the issue and I need to take a closer look at it.    I was creating the list based on an Key consisting of Car and Driver.   the list, as I showed previouly just constisted of Time and Miles.    Once the sorted lists were created for each "Key", I world move thru each list to seperate the miles in Hourly to buckets.   It is now clear that I have create the List based on Cars.   When I pocess each of the Car List, I need to apply special logic if the driver changes.    Do this sound right?


----------



## b.downey (Oct 10, 2012)

This following code accounts for the change in drivers for a single car...

The Code produces the follow results for the data you provided


Datum</SPAN>Ch</SPAN>WP_Wagen</SPAN>Hr</SPAN>Km</SPAN>5/3/2012</SPAN>1006</SPAN>1</SPAN>07:00 ~ 07:59</SPAN>10</SPAN>5/3/2012</SPAN>1006</SPAN>1</SPAN>08:00 ~ 08:59</SPAN>16</SPAN>5/3/2012</SPAN>1006</SPAN>1</SPAN>15:00 ~ 15:59</SPAN>27</SPAN>5/3/2012</SPAN>53</SPAN>1</SPAN>09:00 ~ 09:59</SPAN>59</SPAN>5/3/2012</SPAN>53</SPAN>1</SPAN>10:00 ~ 10:59</SPAN>58</SPAN>

<TBODY>

</TBODY><COLGROUP><COL span=3><COL><COL></COLGROUP>




```
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
```


----------



## bertusavius (Oct 11, 2012)

By the way you explain it, I think you get the essence.
The output is also exactly what I'm looking for.

(I'm running this code on a different machine than usual (I don't know if that matters)) but I receive an overflow error.

This line is highlighted:
tempMins = DateDiff("n", StartTime, DateAdd("h", 1, tempTime))

I treid redefining Dim tempMins As Integer to no avail


----------



## b.downey (Oct 11, 2012)

this error beacuse the Minutes difference between StartTime and TempTime exceeds the Size of an Interger.   

What Data Set are you using?


----------

