Merging Overlapping date ranges for each id

[motherindia]

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

 

[MickG]

Are able to post the a small sample of data it failed on!!!
There does not appear to be anything in the "Dictionary" !!!(Hence No Count)

 

[motherindia]

Thanks Mick Sir.
I tried initially with 4k rows it's working fine without any run time error. May be I should check my data once.
Let me check and revert you soon.

Regards,
motherindia.

 

[motherindia]

Hello Mick Sir,

I am getting error if I have data like following and also if there are duplicate rows;

Cust ID	S Date	E Date
333333	01-04-16	01-04-16
4444455	01-04-16	01-04-16

<tbody>
</tbody>

4444455

01-04-16

01-04-16

<tbody>
</tbody>

If I remove above row (above are at different row ) and re run the macro it will work and macro speed is amazing.
Is there any issue in the data above.

Regards,
motherinida

 

[MickG]

Try this Update:-

[COLOR="Navy"]Sub[/COLOR] MG02Dec47
'[COLOR="Green"][B]Fast Array Update 2/12/16[/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"]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
        [COLOR="Navy"]If[/COLOR] Not Dic(K).Count = 0 [COLOR="Navy"]Then[/COLOR]
        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), 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"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[motherindia]

Hello Mick Sir,

Sorry to bother you again . The issue was resolved, but I am getting incorrect result in the following case;

Cust	Start	End
788900	17-09-15	30-03-17
788900	15-05-16	18-05-16
788900	06-06-16	08-06-16
788900	10-10-16	14-10-16
After macro	Sheet2 as follows;
788900	17-09-15	18-05-16
788900	06-06-16	08-06-16
788900	10-10-16	30-03-17

<tbody>
</tbody><colgroup><col><col><col></colgroup>

 

[MickG]

Try this:-
Its a bit of a rethink !!!

[COLOR="Navy"]Sub[/COLOR] MG03Dec15
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, oMin [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] 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
Ray = Range("A1").CurrentRegion.Resize(, 3)
    ReDim oRes(1 To UBound(Ray, 1), 1 To 3): c = 1
        oRes(1, 1) = "Cust": oRes(1, 2) = "Start": oRes(1, 3) = "End"
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
        Dic.Add Ray(n, 1), Array(n, n)
    [COLOR="Navy"]Else[/COLOR]
        Q = Dic(Ray(n, 1))
           Q(1) = n
        Dic(Ray(n, 1)) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.keys
c = c + 1: oMin = Date: oMax = 0
    [COLOR="Navy"]For[/COLOR] n = Dic(k)(0) To Dic(k)(1)
        oMin = Application.Min(Ray(n, 2), oMin)
        oMax = Application.Max(Ray(n, 3), oMax)
    [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]If[/COLOR] oMax = oMin [COLOR="Navy"]Then[/COLOR]
        oRes(c, 1) = k: oRes(c, 2) = CDate(oMin): oRes(c, 3) = CDate(oMin)
    [COLOR="Navy"]Else[/COLOR]
        oRes(c, 1) = k: oRes(c, 2) = CDate(oMin)
        ReDim sRay(oMin To oMax) [COLOR="Navy"]As[/COLOR] Boolean
            [COLOR="Navy"]For[/COLOR] n = Dic(k)(0) To Dic(k)(1)
                [COLOR="Navy"]For[/COLOR] Dt = CLng(Ray(n, 2)) To CLng(Ray(n, 3))
                    sRay(Dt) = True
                [COLOR="Navy"]Next[/COLOR] Dt
            [COLOR="Navy"]Next[/COLOR] n
        [COLOR="Navy"]For[/COLOR] Dt = oMin To oMax
            [COLOR="Navy"]If[/COLOR] Not Dt = oMax [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]If[/COLOR] sRay(Dt) = True And sRay(Dt + 1) = False [COLOR="Navy"]Then[/COLOR]
                    oRes(c, 3) = CDate(Dt)
                [COLOR="Navy"]ElseIf[/COLOR] sRay(Dt) = False And sRay(Dt + 1) = True [COLOR="Navy"]Then[/COLOR]
                    c = c + 1
                    oRes(c, 1) = k: oRes(c, 2) = CDate(Dt + 1)
                [COLOR="Navy"]End[/COLOR] If
             [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Dt
        oRes(c, 3) = CDate(oMax)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] k
Sheets("Sheet2").Range("A1").Resize(c, 3).Value = oRes
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[motherindia]

Many many thanks Mick Sir!!! This does exactly what I need and
it just took less than 1 min to execute on 60k rows.
Have a really good weekend.
Thanks again for your time and effort.

Regards,
motherindia.

 

[MickG]

That's great news. Thank you for sticking with it !!!
Regrds Mick

 

[motherindia]

Hello Mick Sir,

I will be adding two more column (Cust Name and City) in column D and E.
Is it possible to modify the code to get the details of column D and E.


Extremely sorry to bother you so much.

Regards,
motherindia.

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG11Dec59
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, oMin [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] 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
Ray = Range("A1").CurrentRegion.Resize(, 5)
    ReDim ores(1 To UBound(Ray, 1), 1 To 5): c = 1
        ores(1, 1) = "Cust": ores(1, 2) = "Start"
        ores(1, 3) = "End": ores(1, 4) = "Cust Name": ores(1, 5) = "City"
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
        Dic.Add Ray(n, 1), Array(n, n)
    [COLOR="Navy"]Else[/COLOR]
        Q = Dic(Ray(n, 1))
           Q(1) = n
        Dic(Ray(n, 1)) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.keys
c = c + 1: oMin = Date: oMax = 0
    [COLOR="Navy"]For[/COLOR] n = Dic(k)(0) To Dic(k)(1)
        oMin = Application.Min(Ray(n, 2), oMin)
        oMax = Application.Max(Ray(n, 3), oMax)
    [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]If[/COLOR] oMax = oMin [COLOR="Navy"]Then[/COLOR]
        ores(c, 1) = k: ores(c, 2) = CDate(oMin): ores(c, 3) = CDate(oMin)
        ores(c, 4) = Ray(Dic(k)(0), 4): ores(c, 5) = Ray(Dic(k)(0), 5)
    [COLOR="Navy"]Else[/COLOR]
        ores(c, 1) = k: ores(c, 2) = CDate(oMin)
        ReDim sRay(oMin To oMax) [COLOR="Navy"]As[/COLOR] Boolean
            [COLOR="Navy"]For[/COLOR] n = Dic(k)(0) To Dic(k)(1)
                [COLOR="Navy"]For[/COLOR] Dt = CLng(Ray(n, 2)) To CLng(Ray(n, 3))
                    sRay(Dt) = True
                [COLOR="Navy"]Next[/COLOR] Dt
            [COLOR="Navy"]Next[/COLOR] n
        [COLOR="Navy"]For[/COLOR] Dt = oMin To oMax
            [COLOR="Navy"]If[/COLOR] Not Dt = oMax [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]If[/COLOR] sRay(Dt) = True And sRay(Dt + 1) = False [COLOR="Navy"]Then[/COLOR]
                    ores(c, 3) = CDate(Dt): ores(c, 4) = Ray(Dic(k)(0), 4): ores(c, 5) = Ray(Dic(k)(0), 5)
                [COLOR="Navy"]ElseIf[/COLOR] sRay(Dt) = False And sRay(Dt + 1) = True [COLOR="Navy"]Then[/COLOR]
                    c = c + 1
                    ores(c, 1) = k: ores(c, 2) = CDate(Dt + 1): ores(c, 4) = Ray(Dic(k)(0), 4): ores(c, 5) = Ray(Dic(k)(0), 5)
                [COLOR="Navy"]End[/COLOR] If
             [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Dt
        ores(c, 3) = CDate(oMax): ores(c, 4) = Ray(Dic(k)(0), 4): ores(c, 5) = Ray(Dic(k)(0), 5)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] k
Sheets("Sheet2").Range("A1").Resize(c, 5).Value = ores
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick