P45Cal,
Thank you for your reply. I replace my current code with the code you provided and the line of code "ReDim myresults(1 To maxresults, 1 To 2)" causes an error type 9 "Out or Memory". If I RIM it out the code runs until it gets to the end of the dates for the first person and then I get an error type 13 "Script Out of Range"
Again, thank you for your help.
Sub blah() Dim Wks, zzz, maxresults, rngDates, DestRow, cll, myData, mydatavals, Count, StartBlock, i, myresults
Set Wks = Worksheets("Sheet1")
'dim myResults to a big enough size:
Set zzz = Wks.Range("B1").CurrentRegion
maxresults = Application.CountA(zzz) - zzz.Rows.Count
'ReDim myresults(1 To maxresults, 1 To 2)
Worksheets("Sheet4").Range("A:B").ClearContents
Set rngDates = Wks.Range(Wks.Range("B1"), Wks.Cells(Rows.Count, "B").End(xlUp)).Offset(, -1)
DestRow = 1
For Each cll In rngDates.Cells
Set myData = Wks.Range(cll, Wks.Cells(cll.Row, Columns.Count).End(xlToLeft))
mydatavals = myData.Value
If IsArray(mydatavals) Then
Count = 1: StartBlock = 2
For i = 2 To UBound(mydatavals, 2) - 1
If mydatavals(1, i + 1) - mydatavals(1, i) <= 1 And Year(mydatavals(1, i)) = Year(mydatavals(1, i + 1)) And Month(mydatavals(1, i)) = Month(mydatavals(1, i + 1)) Then
Count = Count + 1
Else
myresults(DestRow, 1) = mydatavals(1, 1)
If Count > 1 Then
myresults(DestRow, 2) = mydatavals(1, StartBlock) & " to " & mydatavals(1, StartBlock + Count - 1)
Else
myresults(DestRow, 2) = mydatavals(1, StartBlock)
End If
DestRow = DestRow + 1
StartBlock = StartBlock + Count: Count = 1
End If
Next i
myresults(DestRow, 1) = mydatavals(1, 1)
If Count > 1 Then
myresults(DestRow, 2) = mydatavals(1, StartBlock) & " to " & mydatavals(1, StartBlock + Count - 1)
Else
myresults(DestRow, 2) = mydatavals(1, StartBlock)
End If
DestRow = DestRow + 1
End If
Next cll
Sheets("Sheet4").Range("A1").Resize(DestRow, 2).Value = myresults
End Sub