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

多个日期期间是否重叠

date_startend()函数需要调用排序函数bubble_sort()《Excel·VBA数组冒泡排序函数》

Function date_overlap(dates)
    '函数定义date_overlap(日期二维数组(开始日期，结束日期))，返回结果各日期期间重叠的日期(str/数组)
    '参数数组、返回数组从1开始计数
    Dim dict As Object, i&, j, n&, result
    If LBound(dates) = UBound(dates) Then date_overlap = "": Exit Function  '只有一组日期，返回空值
    Set dict = CreateObject("scripting.dictionary")
    If LBound(dates) = 0 Or LBound(dates, 2) = 0 Then  '参数检查、规范，转为从1开始计数
        dates = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dates))
    End If
    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)  '和以下mid()一起，mid报错
'            result = result & k(i) & "，"  '拼接重叠日期，末尾有"，"
'        End If
'    Next
'    date_overlap = result
'--------------------以下为输出数组
    result = Array()
    For i = 0 To dict.count - 1:  '遍历字典
        If v(i) > 1 Then
            n = n + 1
            ReDim Preserve result(1 To n)  '重定义数组长度，但数据保留
            result(n) = k(i)
        End If
    Next
    dict.RemoveAll  '清除字典，释放内存
    If UBound(result) <> -1 Then date_overlap = result Else date_overlap = ""
End Function

Function date_startend(dates)
    '函数定义date_startend(日期数组)对日期数组进行整理，如有连续日期则转换为起止日期形式，返回一个数组
    '参数数组为一维数组，返回一维数组从1开始计数
    Dim arr, temp, result, i&, j&
    If LBound(dates) = UBound(dates) Then date_startend = dates: Exit Function  '只有一个日期
    arr = bubble_sort(dates, "+")  '<调用排序函数>
    ReDim result(1 To UBound(arr) - LBound(arr) + 1)  '返回数组
    temp = Array("", "")  '临时起止日期
    For i = LBound(arr) To UBound(arr) - 1
        If temp(0) = "" Then temp(0) = arr(i): temp(1) = arr(i)
        If temp(1) = arr(i + 1) - 1 Then  '连续日期
            temp(1) = arr(i + 1)  '更新止日期
        Else
            j = j + 1
            If temp(0) = temp(1) Then
                result(j) = temp(0): temp = Array("", "")  '返回数组赋值，重置temp数组
            Else
                result(j) = Join(temp, "-"): temp = Array("", "")
            End If
            If i = UBound(arr) - 1 Then j = j + 1: result(j) = arr(UBound(arr))  '最后一组单独日期
        End If
    Next
    If temp(0) <> temp(1) Then j = j + 1: result(j) = Join(temp, "-")  '最后一组连续日期
    If j < UBound(result) Then ReDim Preserve result(1 To j)  '重定义数组长度，但数据保留
    date_startend = result
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
'--------------------数组
'        If IsArray(res) Then
'            Cells(row_write, 7).Resize(1, 3) = Array(k(i), "是", Join(res, ","))
'        Else
'            Cells(row_write, 7).Resize(1, 3) = Array(k(i), "否", "")
'        End If
'--------------------数组+起止日期
        If IsArray(res) Then
            Cells(row_write, 7).Resize(1, 3) = Array(k(i), "是", Join(date_startend(res), ","))
        Else
            Cells(row_write, 7).Resize(1, 3) = Array(k(i), "否", "")
        End If
    Next
End Sub

多种写入形式

多个日期期间是否连续

Function date_discont(dates)
    '函数定义date_discont(日期二维数组(开始日期，结束日期))返回各日期期间不连续的日期数组
    '参数数组为二维数组，返回一维数组，数组都从1开始计数
    Dim dict As Object, result, i&, j&, n&, date_start, date_end, start_end
    If LBound(dates) = UBound(dates) Then date_discont = "": Exit Function  '只有一组日期，返回空值
    Set dict = CreateObject("scripting.dictionary")
    If LBound(dates) = 0 Or LBound(dates, 2) = 0 Then  '参数检查、规范，转为从1开始计数
        dates = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dates))
    End If
    start_end = Array("", "")
    For i = 1 To UBound(dates):  '日期二维数组中所有日期写入字典
        date_start = CDate(dates(i, 1)): date_end = CDate(dates(i, 2))
        For j = date_start To date_end:
            dict(j) = ""
        Next
        If start_end(0) = "" Then
            start_end(0) = date_start: start_end(1) = date_end
        Else
            If start_end(0) > date_start Then start_end(0) = date_start
            If start_end(1) < date_end Then start_end(1) = date_end
        End If
    Next
    ReDim result(1 To start_end(1) - start_end(0))
    For i = start_end(0) To start_end(1)  '最大起止日期遍历，获取不在字典中的日期
        If Not dict.Exists(i) Then
            n = n + 1: result(n) = CDate(i)
        End If
    Next
    If n < UBound(result) And n > 0 Then ReDim Preserve result(1 To n) '重定义数组长度，但数据保留
    If n <> 0 Then date_discont = result Else date_discont = ""
End Function

举例

代码基本与“Sub 日期期间重叠()”一致

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_discont(brr)  '调用函数，获取结果
        row_write = [g1].CurrentRegion.Rows.count + 1  '输出结果区域的第一个空行写入
        If IsArray(res) Then
            Cells(row_write, "g").Resize(1, 3) = Array(k(i), "否", Join(date_startend(res), ","))
        Else
            Cells(row_write, "g").Resize(1, 3) = Array(k(i), "是", "")
        End If
    Next
End Sub