VBA Macro to subtract dates by duplicates ID - ms-access

Question

I would like to create a Macro in VBA to identify the first date and the last date by ID and then get the subtract result between them formatted in hours.
This is an example of my Table:
ID DATE
001 11/11/2013
001 11/21/2013
001 11/25/2013
002 12/04/2013
002 12/05/2013
003 12/05/2013
001 11/23/2013
The desired result:
ID DATE RESULT IN HOURS (Last Date - First Date)
001 11/11/2013 =(11/25/2013)-(11/11/2013)
001 11/21/2013
001 11/25/2013
002 12/04/2013 =(12/05/2013)-(12/04/2013)
002 12/05/2013
003 12/05/2013
001 11/23/2005
In the current table, there are 2 or more duplicates IDs with different Dates as you can see in the 001 ID Sample.
My first solution was sorting the table by ID and Date and then apply a Countif formula to get the duplicates IDs but I was only able to identify the First Date by ID and missing the Last Date.
I would very much appreciate your help. Thanks!

Answer 1

Nice problem. I like the use of collections, because they are quite fast. There must be numerous ways solve a problem like this, the following is one example:
Sub jzz()
Dim cArray() As Variant
Dim lastRow As Long
Dim rw As Long
Dim i As Long
Dim firstDate As Date
Dim lastDate As Date
Dim id As Long
Dim idColl As Collection
Set idColl = New Collection
'determine last row:
lastRow = Cells.SpecialCells(xlLastCell).Row
'if you plan to loop the cells repeatedly,
'the use of an array to hold cell values pays off, performancewise
cArray = Range(Cells(1, 1), Cells(lastRow, 2)).Value
For rw = 1 To lastRow
id = Cells(rw, 1)
'determine if id is used or not:
For i = 1 To idColl.Count
If idColl(i) = id Then GoTo nextRow
Next i
'id is not in collection, add it:
idColl.Add id
firstDate = cArray(rw, 2)
lastDate = 0
'loop array to find first and last dates:
For i = LBound(cArray) To UBound(cArray)
If cArray(i, 1) = id Then
If cArray(i, 2) < firstDate Then firstDate = cArray(i, 2)
If cArray(i, 2) > lastDate Then lastDate = cArray(i, 2)
End If
Next i
Debug.Print id, firstDate, lastDate
nextRow:
Next rw
End Sub
Private Function TimeDiffHours(T0 As Date, T1 As Date) As String
'function that returns the difference between T0 and T1 in hours:mins
TimeDiffHours = Int((T1 - T0) * 24) & ":" _
& Format(Round(((T1 - T0) * 24 - Int((T1 - T0) * 24)) * 60, 0), "00")
End Function
Note that this only finds the first and the last dates for each id and prints it out, along with the time difference in Hours:mins. It does nothing with it, not even save results. That is up to you now.