If you'd rather have a list rather than using the pivot table, try this code.
What it does: first it sorts your list by date and then again by name, that
will provide a list with the names and dates grouped together so that the
rest of the code can easily work through it and determine the number of
consecutive days a person worked.
To put the code into your workbook: open the workbook, press [Alt]+[F11] to
open the VB Editor, then choose Insert --> Module and copy the code below and
paste it into the module presented to you. Make any edits to the Const
values in the code that you need to. Close the VB Editor and run the code
from Tools --> Macro --> Macros.
Sub FindTermOfService()
'the area on the sheet to receive the results
'will have to be cleared of older results before
'running this macro or the new results will
'just be tacked on to the bottom of the older.
'
'change these as needed for your workbook and
'worksheet setups
Const dataSheetName = "Sheet1"
Const namesInColumn = "A"
Const datesInColumn = "B"
Const firstDataRow = "1" ' perhaps 2 if you have labels
'where to put the names/dates found
Const reportColumn = "D" ' names in D, comment in E
Dim dataSheet As Worksheet
Dim dataRange As Range
Dim anyName As Range
Dim sortKey1 As Range
Dim sortKey2 As Range
Dim lastRow As Long
Dim offset2Date As Long
Dim currentName As String
Dim startDate As Date
Dim currentDate As Date
Dim continuousCount As Long
Application.ScreenUpdating = False ' improve performance
'first sort the entire list by dates
Set dataSheet = Worksheets(dataSheetName)
Set dataRange = dataSheet.Range(namesInColumn & firstDataRow & ":" & _
datesInColumn & _
dataSheet.Range(namesInColumn & Rows.Count).End(xlUp).Row)
Set sortKey1 = dataSheet.Range(datesInColumn & firstDataRow)
Set sortKey2 = dataSheet.Range(namesInColumn & firstDataRow)
'first sort them in ascending order by date
dataRange.Sort Key1:=sortKey1, Order1:=xlAscending, Key2:=sortKey2 _
, Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
'then sort them in ascending order by name
dataRange.Sort Key1:=sortKey2, Order1:=xlAscending, Key2:=sortKey1 _
, Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'now you should have list sorted by name and with dates for each name
'in ascending order also
'a little housecleaning
Set sortKey1 = Nothing
Set sortKey2 = Nothing
'how far from date column to name column?
offset2Date = Range(datesInColumn & 1).Column - _
Range(namesInColumn & 1).Column
'redefine dataRange to only include the names column
'need 1 extra, empty, cell to report things properly
Set dataRange = dataSheet.Range(namesInColumn & firstDataRow & ":" & _
dataSheet.Range(namesInColumn & Rows.Count).End(xlUp).Offset(1, 0).Address)
For Each anyName In dataRange ' look through all names
If anyName <> currentName Then
'starting new person's entry
If currentName <> "" Then
'have old information to report
dataSheet.Range(reportColumn & _
Rows.Count).End(xlUp).Offset(1, 0) = currentName
dataSheet.Range(reportColumn & _
Rows.Count).End(xlUp).Offset(0, 1) = _
continuousCount & " day(s) starting on " & _
Format(startDate, "dd-mmm-yyyy")
End If
currentName = anyName
continuousCount = 1
currentDate = anyName.Offset(0, offset2Date)
startDate = currentDate
Else
'name has not changed, if
'date is current date + 1 day then
'part of continuous, otherwise
'starting new period count
If anyName.Offset(0, offset2Date) = _
currentDate + 1 Then
continuousCount = continuousCount + 1
currentDate = _
anyName.Offset(0, offset2Date)
Else
'starting new series, report the old
dataSheet.Range(reportColumn & _
Rows.Count).End(xlUp).Offset(1, 0) = currentName
dataSheet.Range(reportColumn & _
Rows.Count).End(xlUp).Offset(0, 1) = _
continuousCount & " day(s) starting on " & _
Format(startDate, "dd-mmm-yyyy")
currentDate = anyName.Offset(0, offset2Date)
startDate = currentDate
continuousCount = 1
End If
End If
Next
End Sub
