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

[tjrogers04]

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:

ID	start	end
100	1/1/2015	3/1/2015
100	3/1/2015	1/1/2300
100	1/1/2018	1/1/2019
096	7/1/2020	1/1/2021
182	9/17/2017	1/1/2018
182	1/1/2018	1/1/2019
607	1/1/2015	9/1/2015
607	9/1/2015	1/1/2017
607	1/1/2018	1/1/2020
607	1/1/2021	1/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:

ID	start	end
100	1/1/2015	1/1/2300
096	7/1/2020	1/1/2021
182	9/17/2017	1/1/2019
607	1/1/2015	1/1/2017
607	1/1/2018	1/1/2020
607	1/1/2021	1/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.

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

Combining consecutive/overlapping date ranges

Hi all, Haven't been able to figure this out or find an answer. Any help would be greatly appreciated! I have three columns: NAME, START, and END. I'm trying to find a formula/process that will combine any date ranges that are consecutive or overlap (but only for the same person). There are...

www.mrexcel.com

 

[kanadaaa]

Try this in a standard module:

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

 

[kanadaaa]

Sorry the code in #2 is incomplete and leaves blank rows.
I'll post a new one that deletes those rows.

 

[kanadaaa]

Here:

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

 

[chelle1]

I just have to say, this is beautiful! This worked perfectly for something I've been trying to do ... Thank you!!!