Darren Bartrup
Well-known Member
- Joined
- Mar 13, 2006
- Messages
- 1,296
- Office Version
- 365
- Platform
- Windows
This is a duplicate post from SO. I have reworded the question and the code is different, but the problem is the same. Sort Start and End dates into a continuous ordered block
I have two columns of dates representing start and end dates for a period. The rows are in no particular order.
What I'm trying to do is create a new set of dates based on the original showing where the date ranges in the different rows overlap. This may be easier to explain using pictures - I think I muddied the water in my original post and made it confusing.
The dates on the left are my original set. The middle is a manually created example of where the dates overlap. The dates on the right are what my function is or should be returning.
This example has two dates which overlap on the 4th. The dates on the right are what my code correctly returns.
This second example also works.
A final working example:
My code doesn't work for this set of dates though.
The 5th should be pulled out on its own as it sits between two overlapping dates, at the moment it's completely ignored.
Here's the code that creates my final block of dates. It's a cut down version of a larger project (and still very much a work in progress), so excuse any code that raises a question of "why you doing it like that?". The problem part is the commented "Main sorting process" loop.
The dates are sorted by date and whether they're a start or end date with duplicates removed. At the moment the date and the sort order are stored in array `Array(Date, SortOrder)` - the sort order is the date in yymmdd order with a 0 appended for start dates and a 1 for end dates.
(apologies for any bad formatting in the code - what's the best way to copy/paste into MrExcel these days?)
Any help would be greatly appreciated.
I have two columns of dates representing start and end dates for a period. The rows are in no particular order.
What I'm trying to do is create a new set of dates based on the original showing where the date ranges in the different rows overlap. This may be easier to explain using pictures - I think I muddied the water in my original post and made it confusing.
The dates on the left are my original set. The middle is a manually created example of where the dates overlap. The dates on the right are what my function is or should be returning.
This example has two dates which overlap on the 4th. The dates on the right are what my code correctly returns.
This second example also works.
A final working example:
My code doesn't work for this set of dates though.
The 5th should be pulled out on its own as it sits between two overlapping dates, at the moment it's completely ignored.
Here's the code that creates my final block of dates. It's a cut down version of a larger project (and still very much a work in progress), so excuse any code that raises a question of "why you doing it like that?". The problem part is the commented "Main sorting process" loop.
The dates are sorted by date and whether they're a start or end date with duplicates removed. At the moment the date and the sort order are stored in array `Array(Date, SortOrder)` - the sort order is the date in yymmdd order with a 0 appended for start dates and a 1 for end dates.
VBA Code:
Public Function ReturnTest(Target As Range) As Variant
On Error GoTo ErrorHandler
'Place the dates into a collection to remove duplicates dates.
Dim MyDates As Collection
Set MyDates = New Collection
Dim rRow As Range
For Each rRow In Target.Rows
'Start and end dates added to collection.
'Start Dates identified by 0, End Dates by 1 so equal end dates appear after the start date.
MyDates.Add Array(rRow.Cells(1).Value, Format(rRow.Cells(1), "yymmdd0")), Format(rRow.Cells(1), "yymmdd0")
MyDates.Add Array(rRow.Cells(2).Value, Format(rRow.Cells(2), "yymmdd1")), Format(rRow.Cells(2), "yymmdd1")
Next rRow
'Place into an array and sort.
Dim DateArray As Variant
ReDim DateArray(0 To MyDates.Count - 1)
Dim Counter As Long
Dim Itm As Variant
For Each Itm In MyDates
DateArray(Counter) = Itm
Counter = Counter + 1
Next Itm
QuickSort DateArray, 0, UBound(DateArray)
'The main sorting process.
'The For...Next loop looks at each element in the array in turn (CurrentDate)
' - If the date is not an end date then it must be a start date and is used.
' - If the date is an end date and so is the next then the start date is the current date + 1
'
'If the StartDate is not 0 then the end date is calculated.
' - If the next date is an end date then that's the end date.
' - If the next date is a start date, then the end date is the day before that.
Dim tmpCol As New Collection
Dim StartDate As Date, EndDate As Date
Dim CurrentDate As Date, NextDate As Date
Dim CurrentID As String, NextID As String
For Counter = 0 To UBound(DateArray) - 1
StartDate = 0: EndDate = 0
CurrentDate = DateArray(Counter)(0)
CurrentID = DateArray(Counter)(1)
NextDate = DateArray(Counter + 1)(0)
NextID = DateArray(Counter + 1)(1)
If Not IsEndDate(CurrentID) Then
StartDate = CurrentDate
Else
If IsEndDate(NextID) Then
StartDate = CurrentDate + 1
End If
End If
If StartDate > 0 Then
If IsEndDate(NextID) Then
EndDate = NextDate
Else
EndDate = NextDate - 1
End If
tmpCol.Add Array(StartDate, EndDate)
End If
Next Counter
'Place the collection into an array to be passed back
'to the calling procedure.
Dim PaymentDates As Variant
ReDim PaymentDates(0 To tmpCol.Count - 1)
Counter = 0
For Each Itm In tmpCol
PaymentDates(Counter) = Itm
Counter = Counter + 1
Next Itm
ReturnTest = PaymentDates
Exit Function
ErrorHandler:
Select Case Err.Number
Case 457 'This key is already associated with an element of this collection
Resume Next
Case Else
MsgBox Err.Number & vbCr & Err.Description, vbOKOnly + vbExclamation
End Select
End Function
Public Function IsEndDate(DateID As String) As Boolean
IsEndDate = Right(DateID, 1) = 1
End Function
'Sorts the array.
Private Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
Dim pivot As Variant
Dim tmpSwap As Variant
Dim tmpLow As Long
Dim tmpHi As Long
tmpLow = inLow
tmpHi = inHi
pivot = vArray((inLow + inHi) \ 2)
While (tmpLow <= tmpHi)
While (vArray(tmpLow)(1) < pivot(1) And tmpLow < inHi)
tmpLow = tmpLow + 1
Wend
While (pivot(1) < vArray(tmpHi)(1) And tmpHi > inLow)
tmpHi = tmpHi - 1
Wend
If (tmpLow <= tmpHi) Then
tmpSwap = vArray(tmpLow)
vArray(tmpLow) = vArray(tmpHi)
vArray(tmpHi) = tmpSwap
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Wend
If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End SubAny help would be greatly appreciated.
