Combine overlapping dates and find non-overlaps for multiple unique ID's

tjrogers04

New Member
Joined
Apr 16, 2021
Messages
1
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
I have a very large spreadsheet with headers (180k+ rows) with unique ID's in A, start date in B, and end date in C. There are multiple rows per ID and the start and end dates overlap in a messy way.

I need to find any gaps in the date ranges for each ID. I've written a few different formulas and macro's, tried and tweaked other VBA scripts I've found here and elsewhere. I've attempted a power query and power pivot grasping at straws, but if excel doesn't crash I'm not getting a usable output.

Here is an example of the data I have:

IDstartend
1001/1/20153/1/2015
1003/1/20151/1/2300
1001/1/20181/1/2019
0967/1/20201/1/2021
1829/17/20171/1/2018
1821/1/20181/1/2019
6071/1/20159/1/2015
6079/1/20151/1/2017
6071/1/20181/1/2020
6071/1/20211/1/2300

I would like to run a script that combines or consolidates these in someway to remove extra lines for the ID's that do not have any gaps in the date range, but will leave an extra row for the ID's that do:

IDstartend
1001/1/20151/1/2300
0967/1/20201/1/2021
1829/17/20171/1/2019
6071/1/20151/1/2017
6071/1/20181/1/2020
6071/1/20211/1/2300

I don't need it to combine; though, for presentations sake it would be nice. Also, I would settle for something that is able to tell me which ID's have a gap in the range, even if it doesn't combine the dates or remove extra rows.

Newish to VBA and formulas, though this is the first instance I've been unable to get a desired output. Any help or pointing out a better way to approach this would be greatly appreciated.

I did find a script on here from 2012 that almost did the job, though because the date ranges cant all be sorted in proper order, like ID 100 in the example, it creates an extra line when it shouldn't. I'll paste that below.

VBA Code:
Sub Consolidate_Dates()
    
    Dim cell As Range
    Dim Nextrow As Long
    Dim Startdate As Date
    
    Nextrow = Range("A" & Rows.Count).End(xlUp).Row + 2
    Startdate = Range("B2").Value
    
    Application.ScreenUpdating = False
    For Each cell In Range("A2", Range("A2").End(xlDown))
        If cell.Value <> cell.Offset(1).Value Or _
           cell.Offset(0, 2).Value < cell.Offset(1, 1).Value - 1 Then
            Range("A" & Nextrow).Resize(1, 3).Value = cell.Resize(1, 3).Value
            Range("B" & Nextrow).Value = Startdate
            Nextrow = Nextrow + 1
            Startdate = cell.Offset(1, 1).Value
        End If
    Next cell
    Application.ScreenUpdating = True
    
End Sub

 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
Try this in a standard module:
VBA Code:
Sub CombineOverlappingDates()
    Dim lr As Long, cell As Range, ID As Range, tempID As Range
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    Application.ScreenUpdating = False
    For Each cell In Range(Cells(2, "A"), Cells(lr, "A")).Cells
        Set ID = Range(cell, Cells(lr, "A")).Find(cell.Value, , xlValues, xlWhole)
        Set tempID = ID
        If cell = "" Or ID Is Nothing Then GoTo NextIteration
        Do
            If DateValue(ID.Offset(, 1)) < DateValue(cell.Offset(, 1)) And DateValue(cell.Offset(, 2)) < DateValue(ID.Offset(, 2)) Then
                cell.Offset(, 1) = ID.Offset(, 1)
                cell.Offset(, 2) = ID.Offset(, 2)
                ID.Resize(, 3).ClearContents
                GoTo NextID
            End If
            If DateValue(cell.Offset(, 1)) < DateValue(ID.Offset(, 1)) And DateValue(ID.Offset(, 2)) < DateValue(cell.Offset(, 2)) Then
                ID.Resize(, 3).ClearContents
                GoTo NextID
            End If
            If DateValue(cell.Offset(, 2)) = DateValue(ID.Offset(, 1)) Then
                cell.Offset(, 2) = ID.Offset(, 2)
                ID.Resize(, 3).ClearContents
                GoTo NextID
            End If
            If DateValue(cell.Offset(, 1)) = DateValue(ID.Offset(, 2)) Then
                cell.Offset(, 1) = ID.Offset(, 1)
                ID.Resize(, 3).ClearContents
                GoTo NextID
            End If
NextID:
            Set ID = Range(cell, Cells(lr, "A")).FindNext(ID)
            If ID.Row <= tempID.Row Then Exit Do
        Loop While Not ID Is Nothing
NextIteration:
    Next cell
    Application.ScreenUpdating = True
    MsgBox "Done"
End Sub
 
Upvote 0
Sorry the code in #2 is incomplete and leaves blank rows.
I'll post a new one that deletes those rows.
 
Upvote 0
Here:
VBA Code:
Sub CombineOverlappingDates()
    Application.ScreenUpdating = False
    
    'Combine and delete overlapping dates
    Dim lr As Long, cell As Range, ID As Range, tempID As Range
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    
    For Each cell In Range(Cells(2, "A"), Cells(lr, "A")).Cells
        Set ID = Range(cell, Cells(lr, "A")).Find(cell.Value, , xlValues, xlWhole)
        Set tempID = ID
        If cell = "" Or ID Is Nothing Then GoTo NextIteration
        Do
            If DateValue(ID.Offset(, 1)) < DateValue(cell.Offset(, 1)) And DateValue(cell.Offset(, 2)) < DateValue(ID.Offset(, 2)) Then
                cell.Offset(, 1) = ID.Offset(, 1)
                cell.Offset(, 2) = ID.Offset(, 2)
                ID.Resize(, 3).ClearContents
                GoTo NextID
            End If
            If DateValue(cell.Offset(, 1)) < DateValue(ID.Offset(, 1)) And DateValue(ID.Offset(, 2)) < DateValue(cell.Offset(, 2)) Then
                ID.Resize(, 3).ClearContents
                GoTo NextID
            End If
            If DateValue(cell.Offset(, 2)) = DateValue(ID.Offset(, 1)) Then
                cell.Offset(, 2) = ID.Offset(, 2)
                ID.Resize(, 3).ClearContents
                GoTo NextID
            End If
            If DateValue(cell.Offset(, 1)) = DateValue(ID.Offset(, 2)) Then
                cell.Offset(, 1) = ID.Offset(, 1)
                ID.Resize(, 3).ClearContents
                GoTo NextID
            End If
NextID:
            Set ID = Range(cell, Cells(lr, "A")).FindNext(ID)
            If ID.Row <= tempID.Row Then Exit Do
        Loop While Not ID Is Nothing
NextIteration:
    Next cell
    
    'Erase blank rows
    Dim endDownRow As Long
    For Each cell In Range(Cells(2, "A"), Cells(lr, "A")).Cells
        If cell = "" Then
            endDownRow = cell.End(xlDown).Row
            If endDownRow = Rows.Count Then Exit For
            cell.Resize(lr - endDownRow + 1, 3) = Range(Cells(endDownRow, "A"), Cells(lr, "C")).Value
            Cells(lr, "A").Offset(-1 * (endDownRow - cell.Row - 1)).Resize(endDownRow - cell.Row, 3) = ""
            lr = Cells(Rows.Count, "A").End(xlUp).Row
        End If
    Next cell
    
    Application.ScreenUpdating = True
    MsgBox "Done"
End Sub
 
Upvote 0
I'm trying to do this same script and I keep getting error. Same type of situation except my IDs have number and letters.
 
Upvote 0
Here is a formula alternative:

Book8.xlsx
ABCDEFG
11001/1/20153/1/20151001/1/20151/1/2300
21003/1/20151/1/2300967/1/20201/1/2021
31001/1/20181/1/20191829/17/20171/1/2019
4967/1/20201/1/20216071/1/20151/1/2017
51829/17/20171/1/20186071/1/20181/1/2020
61821/1/20181/1/20196071/1/20211/1/2300
76071/1/20159/1/2015
86079/1/20151/1/2017
96071/1/20181/1/2020
106071/1/20211/1/2300
Sheet1
Cell Formulas
RangeFormula
E1:G6E1=LET(recurs, LAMBDA(recurs,d, LET( id, CHOOSECOLS(d, 1), start_d, CHOOSECOLS(d, 2), end_d, CHOOSECOLS(d, 3), min_d, BYROW(d, LAMBDA(x, LET(d_id, CHOOSECOLS(x, 1), d_s, CHOOSECOLS(x, 2), MIN(FILTER(start_d, (id=d_id)*(start_d-1<=d_s)*(end_d+1>=d_s)))))), max_d, BYROW(d, LAMBDA(x, LET(d_id, CHOOSECOLS(x, 1), d_e, CHOOSECOLS(x, 3), MAX(FILTER(end_d, (id=d_id)*(start_d-1<=d_e)*(end_d+1>=d_e)))))), data, UNIQUE(HSTACK(id, min_d, max_d)), IF(ROWS(data)=ROWS(d), data, recurs(recurs, data)) ) ), recurs(recurs, A1:C10) )
Dynamic array formulas.
 
Upvote 0

Forum statistics

Threads
1,223,889
Messages
6,175,223
Members
452,620
Latest member
dsubash

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