Excel VBA или формула: объединение перекрывающихся дат и поиск неперекрывающихся для нескольких уникальных идентификаторов

Вот решение Power Query:

Пожалуйста, прочитайте комментарии в коде и изучите окно примененных шагов, чтобы лучше понять алгоритм, но:

• create a List of the included dates in each range for each ID
  • combine them into a single list
• создать список ВСЕХ возможных дат от самой ранней до самой поздней даты для каждого идентификатора
• Если все даты из диапазона ВСЕ включены в объединенный список, то пропусков нет.
• Create two separate tables
  • one with a Group for the no gap list
  • секунда для списка с пробелами, который мы затем расширяем
• Добавьте две таблицы.

обратите внимание, что многие шаги нельзя выполнить из пользовательского интерфейса

М-код

Вставить в расширенный редактор

убедитесь, что вы изменили имя таблицы в строке 2 на ваше фактическое имя таблицы

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"ID", Int64.Type}, {"start", type date}, {"end", type date}}),

//Turn each date range into a list
    #"Added Custom" = Table.AddColumn(#"Changed Type", "dateList", each 
        List.Dates([start],
                    Duration.Days([end]-[start])+1,
                    #duration(1,0,0,0))),

  //Group the rows by ID
  /*Generate columns where 
      actual date ranges are combined into a list,
      and a list of the Full date range for that ID*/
    #"Grouped Rows" = Table.Group(#"Added Custom", {"ID"}, 
        {{"All", each _, type table [ID=nullable number, start=nullable date, end=nullable date, dateList=list]},
        {"combinedDates", each List.Distinct(List.Combine([dateList]))},
        {"startToEnd", each List.Dates(List.Min([start]),
                                Duration.Days(List.Max([end])-List.Min([start]))+1,
                                #duration(1,0,0,0))}        
        }),

  //if the full list and the combined list Match, then there are no gaps and return True else False        
    #"Added Custom1" = Table.AddColumn(#"Grouped Rows", 
          "Custom", each List.IsEmpty(List.Difference([startToEnd],[combinedDates]))),
    #"Added Custom2" = Table.AddColumn(#"Added Custom1", 
          "start", each if [Custom] = false then null
                else List.Min([combinedDates])),
    #"Added Custom3" = Table.AddColumn(#"Added Custom2", 
          "end", each if [Custom] = false then null 
                else List.Max([combinedDates])),

  //create the table of Trues which we will NOT expand
  trueTbl = Table.SelectRows(#"Added Custom3", each [Custom] = true),
    trueRemoveColumns = Table.RemoveColumns(trueTbl,
            {"All", "combinedDates", "startToEnd","Custom"}),
    trueTyped = Table.TransformColumnTypes(trueRemoveColumns,
            {{"start", type date}, {"end", type date}}),

   //create the table of False which we WILL expand 
  falseTbl = Table.SelectRows(#"Added Custom3", each [Custom] = false),
    expandFalse = Table.ExpandTableColumn(falseTbl, "All", 
            {"start", "end"}, {"start.1", "end.1"}),
    falseRemoveColumns = Table.RemoveColumns(expandFalse,
            {"combinedDates", "startToEnd", "Custom", "start", "end"}),
    falseRenameColumns = Table.RenameColumns(falseRemoveColumns,
            {{"start.1", "start"}, {"end.1", "end"}}),

//Combine the tables
    comb = Table.Combine({trueTyped, falseRenameColumns})
in 
   comb

Попробуй это. Прежде чем начать, убедитесь, что диапазон данных отсортирован по идентификатору и дате начала.

Option Explicit

Public Enum ColId
    ColId_Id = 1
    ColId_Start_Date
    ColId_End_Date
End Enum

Public Sub Test()

    Dim row As Integer
    
    ' Skip the header row & the first data row. 
    ' Start on the second data row.
    row = 3
    
    With Worksheets("Sheet1")
        
        ' Loop until you run out of data
        Do While .Cells(row, ColId_Id) <> ""
            
            ' Compare the current row to the previous row.
            ' We're looking for the same id value and a start date that is 
            ' within or adjoins the previous row's date range.
            If .Cells(row, ColId_Id).Value = .Cells(row - 1, ColId_Id).Value _
            And .Cells(row, ColId_Start_Date).Value >= .Cells(row - 1, ColId_Start_Date).Value _
            And .Cells(row, ColId_Start_Date).Value <= .Cells(row - 1, ColId_End_Date).Value _
            And .Cells(row, ColId_End_Date).Value > .Cells(row - 1, ColId_End_Date).Value _
            Then

                ' Update the previous row and delete the current row.
                .Cells(row - 1, ColId_End_Date).Value = .Cells(row, ColId_End_Date).Value
                .Rows(row).Delete

            Else

                ' Next row.
                row = row + 1

            End If
        
        Loop
    
    End With

End Sub

При этом используется объектно-ориентированный подход. Сначала он добавляет в словарь коллекцию объектов ID, по одному объекту для каждого уникального ID. К каждому объекту идентификатора он добавляет коллекцию диапазонов дат, которые имеет этот идентификатор. По мере добавления каждого промежутка начальные данные сравниваются с предыдущей конечной датой, чтобы решить, есть ли пробел или нет. Данные должны быть отсортированы по идентификатору, дате начала

Поместите входные данные на лист1, вывод идет на лист2. На нем показаны пробелы в столбцах D и E. Также показан сценарий для создания тестовых данных.

Option Explicit

Sub Consolidate_Dates()
    
    Const SHT_DATA = "Sheet1"
    Const SHT_OUTPUT = "Sheet2"

    Dim wb As Workbook, ws As Worksheet
    Dim iLastRow As Long, i As Long, n As Integer
    Dim dict As Object, id As String, objID As clsID
    Dim t0 As Single, ar As Variant, obj As Variant
    t0 = Timer
   
    Set dict = CreateObject("Scripting.Dictionary")
  
    ' scan data on sheet 1
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(SHT_DATA)
    iLastRow = ws.Cells(rows.count, "A").End(xlUp).row
    ar = ws.Range("A2:C" & iLastRow).Value2 ' put data in array
    For i = 1 To UBound(ar)
        id = Trim(ar(i, 1))
        If Not dict.exists(id) Then
            Set objID = New clsID
            objID.id = id
            dict.Add id, objID
        End If
        dict(id).AddSpan CDate(ar(i, 2)), CDate(ar(i, 3))
    Next

    ' results sheet
    With wb.Sheets(SHT_OUTPUT)
        .Cells.Clear
        .Range("A1:E1") = Array("ID", "Start", "End", "Gap Start", "Gap End")
        .Columns("B:E").NumberFormat = "mm/dd/yyyy"
    End With
    ReDim ar(1 To iLastRow, 1 To 5) ' reuse part of array for output
    i = 1
    For Each obj In dict.items
        Set objID = obj
        ' output spans and gaps
        For n = 1 To obj.spansOut.count
            ar(i, 1) = objID.id
            ar(i, 2) = objID.spansOut(n).StartDate
            ar(i, 3) = objID.spansOut(n).EndDate
            ' show gaps
            If n > 1 Then
                ar(i - 1, 4) = objID.spansOut(n - 1).EndDate
                ar(i - 1, 5) = objID.spansOut(n).StartDate
            End If
            i = i + 1
        Next
    Next
    
    ' finish
    Set dict = Nothing
    With wb.Sheets(SHT_OUTPUT)
        .Range("A2:E" & i).Value2 = ar
        .Columns("A:E").AutoFit
        .Activate
        .Range("A1").Select
    End With
    Erase ar
   
    MsgBox Format(i - 1, "#,###") & " rows output to " & SHT_OUTPUT, vbInformation, Int(Timer - t0) & " seconds"
End Sub

Модуль класса с именем clsID

Option Explicit

Public id As String ' unique id
Public hasGaps As Boolean
Public spans As New Collection
Public spansOut As New Collection

Sub AddSpan(dtStart As Date, dtEnd As Date)
    
    Dim spNew As New clsSpan, spLast As clsSpan
    spNew.StartDate = dtStart
    spNew.EndDate = dtEnd
    spans.Add spNew, CStr(spans.count + 1)

    If spansOut.count = 0 Then
        spansOut.Add spNew, "1"
        hasGaps = False
    Else
        Set spLast = spansOut(spansOut.count)
        If spNew.StartDate < spLast.StartDate Then
            MsgBox "Start dates not sorted correctly for " & id, vbCritical
        ElseIf spNew.StartDate > spLast.EndDate Then
            ' add new span
            spansOut.Add spNew, CStr(spansOut.count + 1)
            hasGaps = True
        ElseIf spNew.EndDate > spLast.EndDate Then
            ' extend last span
            spLast.EndDate = spNew.EndDate
        Else
            ' no change
        End If
    End If
End Sub

Модуль класса с именем clsSpan

Option Explicit

Public StartDate As Date
Public EndDate As Date

Скрипт для генерации случайных тестовых данных

Sub testdata()
    Const ROW_COUNT = 200000
    Dim dt1 As Date, i As Long
    Sheet1.Cells.Clear
    For i = 2 To ROW_COUNT + 1
        Sheet1.Cells(i, 1) = 1000 + Int(9000 * Rnd)
        dt1 = CDate("1/1/2000") + Int(3650 * Rnd)
        Sheet1.Cells(i, 2) = dt1
        Sheet1.Cells(i, 3) = dt1 + Int(1000 * Rnd)
    Next

    With Sheet1.Sort
        .SortFields.Clear
        .SortFields.Add key:=Range("A1:A" & i)
        .SortFields.Add key:=Range("B1:B" & i)
        .SetRange Range("A1:C" & i)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheet1.Activate
    Sheet1.Range("A" & ROW_COUNT + 1).Select
   
    MsgBox Format(ROW_COUNT, "#,###") & " rows created and sorted"
End Sub