Merging Overlapping date ranges for each id

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
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Try this:-
Results sheet2
Code:
[COLOR="Navy"]Sub[/COLOR] MG28Nov54
[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] Dt [COLOR="Navy"]As[/COLOR] Date, nDt [COLOR="Navy"]As[/COLOR] Variant, Ray, Col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] myArrayList [COLOR="Navy"]As[/COLOR] Object, Dic [COLOR="Navy"]As[/COLOR] Object, K [COLOR="Navy"]As[/COLOR] Variant
c = 1
[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.Offset(, 1)
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = Union(Dic(Dn.Value), Dn.Offset(, 1))
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
ReDim Ray(1 To Rng.Count, 1 To 3)
Ray(1, 1) = "Cust": Ray(1, 2) = "Start": Ray(1, 3) = "End"
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
  [COLOR="Navy"]Set[/COLOR] myArrayList = CreateObject("System.Collections.ArrayList")
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Dic(K)
        [COLOR="Navy"]For[/COLOR] Dt = Dn.Value To Dn.Offset(, 1)
           [COLOR="Navy"]If[/COLOR] Not myArrayList.contains(CDbl(DateValue(Dt))) [COLOR="Navy"]Then[/COLOR]
                myArrayList.Add CDbl(DateValue(Dt))
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Dt
     [COLOR="Navy"]Next[/COLOR]
     myArrayList.Sort
    
    c = c + 1
    Ray(c, 1) = K
    Ray(c, 2) = CDate(myArrayList(0))
    [COLOR="Navy"]For[/COLOR] n = 1 To myArrayList.Count - 1
        [COLOR="Navy"]If[/COLOR] Not myArrayList(n - 1) + 1 = myArrayList(n) [COLOR="Navy"]Then[/COLOR]
            Ray(c, 3) = CDate(myArrayList(n - 1)): Ray(c, 1) = K
            c = c + 1
            Ray(c, 2) = CDate(myArrayList(n)): Ray(c, 1) = K
        [COLOR="Navy"]End[/COLOR] If
   
[COLOR="Navy"]Next[/COLOR] n
   Ray(c, 3) = CDate(myArrayList(myArrayList.Count - 1)): Ray(c, 1) = K
 [COLOR="Navy"]Next[/COLOR] K
   [COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 3)
    .Value = Ray
    .Borders.Weight = 2
    .Columns.AutoFit
   [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Dear Mick Sir,

First and for most sorry for the delayed responses. I checked it with sample data and it's working fine.
I will revert you soon for any further issue on bulk data.

Regards,
motherindia
 
Upvote 0
Hello Mick Sir,

I tired it on 50k rows and it took around 45 min. Is it possible to increase the speed.
Thanks once again.

Regards,
motherinida
 
Upvote 0
Try this :-
Its the best I can Do!!!!
Code:
[COLOR="Navy"]Sub[/COLOR] MG30Nov25
'[COLOR="Green"][B]Array[/B][/COLOR]
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dt [COLOR="Navy"]As[/COLOR] Date, Ray
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] myArrayList [COLOR="Navy"]As[/COLOR] Object, Dic [COLOR="Navy"]As[/COLOR] Object, K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] sRay [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Variant, Q [COLOR="Navy"]As[/COLOR] Variant
c = 1
sRay = Range("A1").CurrentRegion.Resize(, 3)
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 2 To UBound(sRay, 1)
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(sRay(n, 1)) [COLOR="Navy"]Then[/COLOR]
        ReDim R(1 To 2, 1 To 1)
        R(1, 1) = sRay(n, 2): R(2, 1) = sRay(n, 3)
        Dic.Add sRay(n, 1), R
    [COLOR="Navy"]Else[/COLOR]
        Q = Dic(sRay(n, 1))
            ReDim Preserve Q(1 To 2, 1 To UBound(Q, 2) + 1)
            Q(1, UBound(Q, 2)) = sRay(n, 2)
            Q(2, UBound(Q, 2)) = sRay(n, 3)
        Dic(sRay(n, 1)) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
ReDim Ray(1 To UBound(sRay, 1), 1 To 3)
Ray(1, 1) = "Cust": Ray(1, 2) = "Start": Ray(1, 3) = "End"
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
  [COLOR="Navy"]Set[/COLOR] myArrayList = CreateObject("System.Collections.ArrayList")
    [COLOR="Navy"]For[/COLOR] n = 1 To UBound(Dic(K), 2)
        [COLOR="Navy"]For[/COLOR] Dt = CDbl(DateValue(Dic(K)(1, n))) To CDbl(DateValue(Dic(K)(2, n)))
           [COLOR="Navy"]If[/COLOR] Not myArrayList.contains(CDbl(DateValue(Dt))) [COLOR="Navy"]Then[/COLOR]
                myArrayList.Add CDbl(DateValue(Dt))
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Dt
     [COLOR="Navy"]Next[/COLOR] n
    myArrayList.Sort
    c = c + 1
    Ray(c, 1) = K
    Ray(c, 2) = CDate(myArrayList(0))
    [COLOR="Navy"]For[/COLOR] n = 2 To myArrayList.Count - 1
        [COLOR="Navy"]If[/COLOR] Not myArrayList(n - 1) + 1 = myArrayList(n) [COLOR="Navy"]Then[/COLOR]
            Ray(c, 3) = CDate(myArrayList(n - 1)): Ray(c, 1) = K
            c = c + 1
            Ray(c, 2) = CDate(myArrayList(n)): Ray(c, 1) = K
        [COLOR="Navy"]End[/COLOR] If
   
[COLOR="Navy"]Next[/COLOR] n
   Ray(c, 3) = CDate(myArrayList(myArrayList.Count - 1)): Ray(c, 1) = K
 [COLOR="Navy"]Next[/COLOR] K
   [COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 3)
    .Value = Ray
    .Borders.Weight = 2
    .Columns.AutoFit
   [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Thanks Once again Mick Sir. The above code is working fine and I could complete it in 24 min which saved 50% time saving. This would do for me.

Thanks a ton.

Regards,
motherindia
 
Upvote 0
Try this, If accurate, its a lot faster !!!
Code:
[COLOR="Navy"]Sub[/COLOR] MG01Dec10
'[COLOR="Green"][B]Fast Array[/B][/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range, Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] j [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] i [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, P [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, M [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Tot [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] temp1 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Temp2 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Temp3 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] fd [COLOR="Navy"]As[/COLOR] Boolean, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[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"]For[/COLOR] col = 1 To 2
            [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(Dn.Offset(, col).Value) [COLOR="Navy"]Then[/COLOR]
                Dic(Dn.Value).Add (Dn.Offset(, col).Value), col
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).Item(Dn.Offset(, 1).Value) = col [COLOR="Navy"]Then[/COLOR]
                    Dic(Dn.Value).Remove (Dn.Offset(, col).Value)
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]End[/COLOR] If
       [COLOR="Navy"]Next[/COLOR] col
   [COLOR="Navy"]Next[/COLOR] Dn
M = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
        Tot = Tot + M
        c = 0
         ReDim Ray(1 To Dic(K).Count, 1 To 3)
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] P [COLOR="Navy"]In[/COLOR] Dic(K)
               c = c + 1
               Ray(c, 1) = K
               Ray(c, 2) = P
               Ray(c, 3) = Dic(K)(P)
        [COLOR="Navy"]Next[/COLOR] P
[COLOR="Navy"]For[/COLOR] i = 1 To UBound(Ray, 1)
    [COLOR="Navy"]For[/COLOR] j = i To UBound(Ray)
        [COLOR="Navy"]If[/COLOR] Ray(j, 2) < Ray(i, 2) [COLOR="Navy"]Then[/COLOR]
            temp1 = Ray(i, 1)
            Temp2 = Ray(i, 2)
            Temp3 = Ray(i, 3)
                Ray(i, 1) = Ray(j, 1)
                Ray(i, 2) = Ray(j, 2)
                Ray(i, 3) = Ray(j, 3)
            Ray(j, 1) = temp1
            Ray(j, 2) = Temp2
            Ray(j, 3) = Temp3
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] j
[COLOR="Navy"]Next[/COLOR] i
M = 1
ReDim nRay(1 To UBound(Ray, 1) / 2, 1 To 3)
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
    [COLOR="Navy"]If[/COLOR] fd = False [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Ray(n, 3) = 1 [COLOR="Navy"]Then[/COLOR]
            fd = True
             nRay(M, 1) = Ray(n, 1)
            nRay(M, 2) = CDate(Ray(n, 2))
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]If[/COLOR] fd = True [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] True
            [COLOR="Navy"]Case[/COLOR] n = UBound(Ray, 1)
                nRay(M, 3) = CDate(Ray(n, 2))
                fd = False
            [COLOR="Navy"]Case[/COLOR] Ray(n, 3) = 2 And Ray(n + 1, 3) = 1
                nRay(M, 3) = CDate(Ray(n, 2))
                M = M + 1
                fd = False
        [COLOR="Navy"]End[/COLOR] Select
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    .Range("A1").Offset(Tot).Resize(M, 3) = nRay
    .Range("A1").Resize(, 3) = Array("Cust", "Start", "End")
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hello Mick Sir.

Thanks once again for taking a lot more efforts .It's very very fast.
But I got Run time error 9 in the following line ;

ReDim Ray(1 To Dic(K).Count, 1 To 3)


Regards,
motherindia
 
Upvote 0

Forum statistics

Threads
1,213,484
Messages
6,113,923
Members
448,533
Latest member
thietbibeboiwasaco

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