UDF to separate date ranges where they overlap.

Darren Bartrup

Well-known Member
Joined
Mar 13, 2006
Messages
1,295
Office Version
  1. 365
Platform
  1. 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.
Example 1.PNG


This second example also works.
Example 2.PNG


A final working example:
Example 3.PNG


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.
Example 4.PNG


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 Sub
(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.
 

Some videos you may like

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney

pgc01

MrExcel MVP
Joined
Apr 25, 2006
Messages
19,884
Hi

With the date brackets in A:B row 2 down, result in C:D row 2 down, try:


VBA Code:
Sub Test()
Dim r As Range
Dim lDates() As Long, lResult() As Long
Dim j As Long, k As Long

Set r = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row)
ReDim lDates(Application.Min(r) To Application.Max(r)) As Long

' count each date
For j = 1 To r.Count / 2
    For k = r(j, 1) To r(j, 2)
        lDates(k) = lDates(k) + 1
    Next k
Next j

' build result array
ReDim lResult(1 To UBound(lDates) - LBound(lDates) + 1, 1 To 2)
k = 0
For j = LBound(lDates) To UBound(lDates)
     If lDates(j) > 0 Then
             k = k + 1
             lResult(k, 1) = j
         If lDates(j) > 1 Then
             lResult(k, 2) = j
         Else
             Do While j <= UBound(lDates)
                If lDates(j) <> 1 Then Exit Do
                j = j + 1
             Loop
             j = j - 1
             lResult(k, 2) = j
        End If
    End If
Next j

Range("C2").Resize(k, 2).Value = lResult

End Sub


Ex.:


Book1
ABCDE
1
201-01-202002-01-202001-01-202002-01-2020
304-01-202006-01-202004-01-202004-01-2020
405-01-202005-01-202005-01-202005-01-2020
506-01-202006-01-2020
6
Sheet3
 

Darren Bartrup

Well-known Member
Joined
Mar 13, 2006
Messages
1,295
Office Version
  1. 365
Platform
  1. Windows
Thanks pgc01. I hadn't thought of doing it that way. There is one problem though which I didn't highlight in my question - apologies for that.

Not sure how to word it, so maybe explain how it will be used. Each row will also have a monetary value attached to it, so I need to know where each separate row overlaps as well as where it starts and ends.

Using the example below (installed the add-in now).
StartEndValue
1.30/12/201831/12/2018£ 1,000.00
2.01/01/201905/01/2019£ 750.00
3.03/01/201907/01/2019-£ 100.00
4.06/01/201908/01/2019£ 200.00


Expanded this looks like this:
StartEndStartEndStartEndStartEndStart / End
1.30/12/201831/12/2018
2.01/01/201902/01/201903/01/201904/01/201905/01/2019
3.03/01/201904/01/201905/01/201906/01/201907/01/2019
4.06/01/201907/01/201908/01/2019
Total£1,000.00£750.00£650.00£100.00£200.00


What I'd expect to get is on the left, and your code results are on the right.
30/12/201831/12/201830/12/201802/01/2019
01/01/201902/01/201903/01/201903/01/2019
03/01/201905/01/201904/01/201904/01/2019
06/01/201907/01/201905/01/201905/01/2019
08/01/201908/01/201906/01/201906/01/2019
07/01/201907/01/2019
08/01/201908/01/2019


I'll have additional information to add to those values which is why I didn't include in the original question. Apologies for that oversite.
I'm not sure if you're original line of thinking can be adapted to this new info?
 

pgc01

MrExcel MVP
Joined
Apr 25, 2006
Messages
19,884
If I understood correctly you want the result date brackets according to the total monetary value.

If that's the case, try:

VBA Code:
Sub Test()
Dim r As Range
Dim vDates() As Variant, vResult() As Variant
Dim j As Long, k As Long

Set r = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row)
ReDim vDates(Application.Min(r) To Application.Max(r))

' count each date
For j = 1 To r.Count / 2
    For k = r(j, 1) To r(j, 2)
        vDates(k) = vDates(k) + r(j, 3)
    Next k
Next j

' build result array
ReDim vResult(1 To UBound(vDates) - LBound(vDates) + 1, 1 To 3)
k = 0
For j = LBound(vDates) To UBound(vDates)
    If vDates(j) <> 0 Then
        k = k + 1
        vResult(k, 1) = j
        vResult(k, 3) = vDates(j)
        
        Do While j < UBound(vDates)
           If vDates(j) <> vDates(j + 1) Then Exit Do
           j = j + 1
        Loop
        
        vResult(k, 2) = j
    End If
Next j

Columns("E:F").NumberFormat = "yyyy-mm-dd"
Range("E2").Resize(k, 3).Value = vResult

End Sub

Ex.

Book1
ABCDEFGH
1
230/12/201831/12/20181,00030/12/201831/12/20181000
301/01/201905/01/201975001/01/201902/01/2019750
403/01/201907/01/2019-10003/01/201905/01/2019650
506/01/201908/01/201920006/01/201907/01/2019100
608/01/201908/01/2019200
7
Sheet1
 
Solution

Darren Bartrup

Well-known Member
Joined
Mar 13, 2006
Messages
1,295
Office Version
  1. 365
Platform
  1. Windows
Morning pgc01.

I think that works. I removed the If vDates(j) <> 0 Then check as I want it to show zero balances as well.
Now I've just got to add some code to ignore certain rows, perform a few calculations on the values based on frequency of payments, but it looks like you've solved my main stumbling block.

Thank you so much. :)
 

Watch MrExcel Video

Forum statistics

Threads
1,127,107
Messages
5,622,782
Members
415,927
Latest member
vedasinternational

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top