Excel·VBA多个日期期间是否重叠

贴吧提问《如何在相同编码里，判断是否有日期重叠》，对多组日期期间是否有重叠的日期进行计算，参考贴子回复编写代码，使其更具通用性
一个自定义函数计算和一个过程（函数参数为二维数组）

Function date_overlap(dates)
    '函数定义date_overlap(日期二维数组(开始日期，结束日期))，返回结果各日期期间重叠的日期(str)
    Dim dict As Object, result As String
    Set dict = CreateObject("scripting.dictionary")
    For i = 1 To UBound(dates):
        For j = dates(i, 1) To dates(i, 2):
            If Not dict.Exists(j) Then  '新键-值（日期-出现次数）
                dict(j) = 1
            Else  '已有键-值，更新
                dict(j) = dict(j) + 1
            End If
        Next
    Next
    
    k = dict.keys
    v = dict.Items
    For i = 0 To dict.count - 1:  '遍历字典
        If v(i) > 1 Then
            result = result & k(i) & "，"  '拼接重叠日期
        End If
    Next
    date_overlap = result
    dict.RemoveAll  '清除字典，释放内存
    
End Function

Sub 日期期间重叠()
    
    Dim arr, brr, k, v, res, dict As Object
    Set dict = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr):  '编码去重，统计出现次数，以便重新定义brr数组
        If Not dict.Exists(arr(i, 1)) Then  '新键-值
            dict(arr(i, 1)) = 1
        Else
            dict(arr(i, 1)) = dict(arr(i, 1)) + 1
        End If
    Next
    
    k = dict.keys
    v = dict.Items
    For i = 0 To dict.count - 1:  '遍历字典
        ReDim brr(1 To v(i), 1 To 2)  '重新定义brr数组
        x = 1
        For j = 2 To UBound(arr):  '遍历arr数组
            If k(i) = arr(j, 1) Then
                brr(x, 1) = arr(j, 2): brr(x, 2) = arr(j, 3)  '赋值brr数组
                x = x + 1
            End If
        Next
        res = date_overlap(brr)  '调用函数，获取结果
        row_write = [g1].CurrentRegion.Rows.count + 1  '输出结果区域的第一个空行写入
        If res <> "" Then  '写入结果
            Cells(row_write, 7).Resize(1, 3) = Array(k(i), "是", res)
        Else
            Cells(row_write, 7).Resize(1, 3) = Array(k(i), "否", res)
        End If
    Next
            
End Sub

举例：

日期重叠-举例