Merging Overlapping date ranges for each id

M

motherindia

Board Regular
Joined
Oct 15, 2015
Messages
218
Hello Sir,

I Have list of Start date and end Date for each custmer . Column A contains Cust ID and other 2 columns contain Start date and End Date. Basically I need to combine start date and end date if the dates are overlapping each otherand date are consecutive or dates are duplicated else it should remain same.

Following is the Data on SHeet1 and Output sheet should on another sheet.
Data on Sheet1

Cust no Start Date End Date
1111111 23-08-16 25-08-16
1111111 22-08-16 22-08-16
1111111 08-11-14 02-12-16
2222222 12-10-16 30-11-16
2222222 20-07-16 30-09-16
2222222 14-02-16 23-02-16
2222222 14-02-16 23-02-16


Output on Sheet2

Cust no Start Date End Date
1111111 08-11-14 02-12-16
2222222 12-10-16 30-11-16
2222222 20-07-16 30-09-16
2222222 14-02-16 23-02-16

Regards,
motherindia
 
Sort by date Sort by votes
Thanks Mick Sir Once again for quick responses and for all your support.
It's exactly what I expected . Bingo :) :)

Regards,
motherindia
 
Upvote 0

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
MickG said:
You're welcome
Click to expand...

Hi MickG,

I have a similar problem with overlapping dates but my data also includes hours. So the format is "18.01.2017 22:00".

The problem is that when I run this code I get results only as the date without the hours and the end dates are wrong; they end the next day. To give an example;


Original data for one ID;

 ID Start Date End Date
1111 06.01.2017 09:00 06.01.2017 12:00
1111 18.01.2017 09:00 18.01.2017 12:00
1111 18.01.2017 09:30 18.01.2017 17:00
1111 21.01.2017 09:30 21.01.2017 17:30

How it should be combined after macro has run;

ID Start Date End Date
1111 06.01.2017 09:00 06.01.2017 12:00
1111 18.01.2017 09:00 18.01.2017 17:00
1111 21.01.2017 09:30 21.01.2017 17:30

How it actually happens;
ID Start Date End Date
1111 06.01.2017 07.01.2017
1111 18.01.2017 19.01.2017
1111 21.01.2017 22.01.2017

So the end date is one day more than how it should be, and the hours are lost which are critical to my application.

I would really appreciate your help with this.
 
Upvote 0
Try this, for results starting "F1".
NB:- The dates and times columns must be formatted as Dates/Times.
Your date delimiters are ".", that is text to me , Might be date to you ?????
Code: 
[COLOR="Navy"]Sub[/COLOR] MG22Feb04
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range, Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] k [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] Variant
 
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
          [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).exists(CDbl(DateValue(Dn.Offset(, 1)))) [COLOR="Navy"]Then[/COLOR]
                Dic(Dn.Value).Add (CDbl(DateValue(Dn.Offset(, 1)))), _
                Array(CDbl(Dn.Offset(, 1)), CDbl(Dn.Offset(, 2)))
        [COLOR="Navy"]Else[/COLOR]
                Q = Dic(Dn.Value).Item(CDbl(DateValue(Dn.Offset(, 1))))
                [COLOR="Navy"]If[/COLOR] CDbl(Dn.Offset(, 1)) < Q(0) [COLOR="Navy"]Then[/COLOR] Q(0) = CDbl(Dn.Offset(, 1))
                [COLOR="Navy"]If[/COLOR] CDbl(Dn.Offset(, 2)) > Q(1) [COLOR="Navy"]Then[/COLOR] Q(1) = CDbl(Dn.Offset(, 2))
                Dic(Dn.Value).Item(CDbl(DateValue(Dn.Offset(, 1)))) = Q
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
   
Range("F1").Resize(, 3).Value = Array("ID", "Start Date", "End Date")
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
       [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k)
            c = c + 1
            Cells(c, "F") = k
            Cells(c, "G") = CDate(Dic(k).Item(p)(0))
            Cells(c, "H") = CDate(Dic(k).Item(p)(1))
        [COLOR="Navy"]Next[/COLOR] p
   [COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
MickG said:
Try this, for results starting "F1".
NB:- The dates and times columns must be formatted as Dates/Times.
Your date delimiters are ".", that is text to me , Might be date to you ?????

Regards Mick
Click to expand...

Thank you very much Mick! It works with a minor problem; it also adds up the ranges that are on the same day which aren't overlapping. This is good if they are consecutive but it creates a problem if not. Let me show you in an example:

ID

Start Date

End Date

1111

04.01.2017 12:30

04.01.2017 13:30

1111

04.01.2017 18:30

04.01.2017 22:00


<tbody>
</tbody>

It merges these two ranges as this;

ID

Start Date

End Date

1111

04.01.2017 12:30

04.01.2017 22:00


<tbody>
</tbody>
This is incorrect because it also includes hours which aren't included in the ranges above.

However it I also have a situation like this where ranges are consecutive:

ID

Start Date

End Date

7197

14.01.2017 10:00

14.01.2017 13:00

7197

14.01.2017 13:00

14.01.2017 16:00


<tbody>
</tbody>

After the code is run I get this:

ID

Start Date

End Date

7197

14.01.2017 10:00

14.01.2017 16:00


<tbody>
</tbody>
Which is correct.

Thanks again for your help.
 
Upvote 0
Try this for results starting "F!"
NB:- The code assumes that there are no blank cells where there should be a date.
Code: 
[COLOR="Navy"]Sub[/COLOR] MG24Feb52
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Tim [COLOR="Navy"]As[/COLOR] Date, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] R [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, K [COLOR="Navy"]As[/COLOR] Variant, Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Application.ScreenUpdating = False
Columns("F:H").Clear
Range("F1").Resize(, 3).Value = Array("ID", "Start Date", "End Date")
Temp = 2
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
  [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
     Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Dic.Add Dn.Value, Dn
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = Union(Dic(Dn.Value), Dn)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
    ReDim nRay(1 To 1440, 1 To 2)
    ReDim Ray(1 To 1440): c = 0
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Dic(K)
        [COLOR="Navy"]For[/COLOR] n = 1 To 1440
            Tim = Format(DateAdd("n", n, "00:00:00"), "hh:mm")
                [COLOR="Navy"]If[/COLOR] Tim >= TimeValue(Dn.Offset(, 1).Value) And Tim <= TimeValue(Dn.Offset(, 2).Value) [COLOR="Navy"]Then[/COLOR]
                    Ray(n) = Tim
                [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]Next[/COLOR] Dn
    [COLOR="Navy"]For[/COLOR] n = 1 To 1440 - 1
        [COLOR="Navy"]If[/COLOR] IsEmpty(Ray(n)) And Not IsEmpty(Ray(n + 1)) [COLOR="Navy"]Then[/COLOR]
            c = c + 1
            nRay(c, 1) = Format(DateValue(Dic(K)(1).Offset(, 1).Value) + Ray(n + 1), "dd/mm/yyyy  hh:mm")
        [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]If[/COLOR] IsEmpty(Ray(n + 1)) And Not IsEmpty(Ray(n)) [COLOR="Navy"]Then[/COLOR]
            nRay(c, 2) = Format(DateValue(Dic(K)(1).Offset(, 2).Value) + Ray(n), "dd/mm/yyyy  hh:mm")
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] n
    Cells(Temp, "G").Resize(c, 2) = nRay
    Cells(Temp, "F").Resize(c) = K
    Temp = Temp + c
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]With[/COLOR] Range("F1").Resize(Temp - 1, 3)
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Update !!-- Unfortunately I based the previous code on incorrect data. I think this new code should do !!
Results start "F1".
Code: 
[COLOR="Navy"]Sub[/COLOR] MG25Feb49
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range, Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] k [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Tim [COLOR="Navy"]As[/COLOR] Date, Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Application.ScreenUpdating = False
Columns("F:H").Clear
Range("F1").Resize(, 3).Value = Array("ID", "Start Date", "End Date")
Temp = 2
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
       [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
             [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
        [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).exists(DateValue(Dn.Offset(, 1))) [COLOR="Navy"]Then[/COLOR]
             Dic(Dn.Value).Add (DateValue(Dn.Offset(, 1))), Dn
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value).Item(DateValue(Dn.Offset(, 1))) = _
            Union(Dic(Dn.Value).Item(DateValue(Dn.Offset(, 1))), Dn)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
     
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
  [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k)
     ReDim nRay(1 To 1440, 1 To 2)
     ReDim Ray(1 To 1440): c = 0
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Dic(k).Item(p)
        [COLOR="Navy"]For[/COLOR] n = 1 To 1440
            Tim = Format(DateAdd("n", n, "00:00:00"), "hh:mm")
                [COLOR="Navy"]If[/COLOR] Tim >= TimeValue(Dn.Offset(, 1).Value) And Tim <= TimeValue(Dn.Offset(, 2).Value) [COLOR="Navy"]Then[/COLOR]
                    Ray(n) = Tim
                [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]Next[/COLOR] Dn
    [COLOR="Navy"]For[/COLOR] n = 1 To 1440 - 1
        [COLOR="Navy"]If[/COLOR] IsEmpty(Ray(n)) And Not IsEmpty(Ray(n + 1)) [COLOR="Navy"]Then[/COLOR]
            c = c + 1
            nRay(c, 1) = Format(DateValue(p) + Ray(n + 1), "dd/mm/yyyy  hh:mm")
        [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]If[/COLOR] IsEmpty(Ray(n + 1)) And Not IsEmpty(Ray(n)) [COLOR="Navy"]Then[/COLOR]
            nRay(c, 2) = Format(DateValue(p) + Ray(n), "dd/mm/yyyy  hh:mm")
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] n
    
    Cells(Temp, "G").Resize(c, 2) = nRay
    Cells(Temp, "F").Resize(c) = k
    Temp = Temp + c
  [COLOR="Navy"]Next[/COLOR] p
[COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]With[/COLOR] Range("F1").Resize(Temp - 1, 3)
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
On checking the code above I noted the dates where not formatting correctly.
Change lines as shown below:-
Code: 
For n = 1 To 1440 - 1
        If IsEmpty(Ray(n)) And Not IsEmpty(Ray(n + 1)) Then
            c = c + 1
            nRay(c, 1) = p + Ray(n + 1) ' New line
           
           'Remove this line
           'nRay(c, 1) = Format(DateValue(p) + Ray(n + 1), "dd/mm/yyyy  hh:mm")
        End If
        If IsEmpty(Ray(n + 1)) And Not IsEmpty(Ray(n)) Then
            nRay(c, 2) = p + Ray(n) 'New line
           
           ' Remove this line
           'nRay(c, 2) = Format(DateValue(p) + Ray(n), "dd/mm/yyyy  hh:mm")
        End If
    Next n
 
Upvote 0
MickG said:
On checking the code above I noted the dates where not formatting correctly.
Change lines as shown below:-
Code: 
For n = 1 To 1440 - 1
        If IsEmpty(Ray(n)) And Not IsEmpty(Ray(n + 1)) Then
            c = c + 1
            nRay(c, 1) = p + Ray(n + 1) ' New line
           
           'Remove this line
           'nRay(c, 1) = Format(DateValue(p) + Ray(n + 1), "dd/mm/yyyy  hh:mm")
        End If
        If IsEmpty(Ray(n + 1)) And Not IsEmpty(Ray(n)) Then
            nRay(c, 2) = p + Ray(n) 'New line
           
           ' Remove this line
           'nRay(c, 2) = Format(DateValue(p) + Ray(n), "dd/mm/yyyy  hh:mm")
        End If
    Next n
Click to expand...

Thank you very much! This works perfectly.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
How to Highlight Month-end dates
Replies
3
Views
357
kevin9999
K
A
  • Solved
Returning name on multiple date arrays
Replies
9
Views
371
archibell
A
S
  • Solved
Calculate Revert Time
Replies
6
Views
401
felixstraube
F
J
  • Solved
Add 1 day to a date within a range as long as 2 conditions are met [without macros]
Replies
4
Views
555
juanam
J
AOB
  • Question
Calculate the "true" duration of up/down times accounting for gaps and overlaps
Replies
1
Views
248
AOB
AOB

Forum statistics

Threads
1,214,518
Messages
6,119,985
Members
448,935
Latest member
ijat

Share this page

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
Back
Top