☰

如何将连续的日期汇总到单个日期范围内？

tag-icon • tag-icon microsoft-excel
如何将连续的日期汇总到单个日期范围内？

如何总结日期？

在此处输入图片描述

例如：我有很多约会

A1: 1/2/2023
A2: 2/2/2023
A3: 3/2/2023
A4: 4/2/2023
A5: 6/2/2023
A6: 7/2/2023
A7: 8/2/2023
A8: 10/2/2023
A9: 12/2/2023
A10: 13/2/2023
A11: 16/2/2023
A12: 17/2/2023
A13: 20/2/2023
A14: 25/2/2023

VBA后如何设置结果显示如下？

1/2/2023-4/2/2023, 6/2/2023-8/2/2023, 10/2/2023, 12/2/2023-13/2/2023, 16/2/2023-17/2/2023, 20/2/2023, 25/2/2023

答案1

如果 ms365 是一个选项：

在此处输入图片描述

公式B1：

=LET(x,A2:A14-A1:A13,REDUCE(TEXT(A1,"dd/mm/yyyy"),SEQUENCE(COUNT(x)),LAMBDA(y,z,IF(INDEX(x,z)=1,IF(LEFT(RIGHT(y,11))="-",TEXTBEFORE(y,"-",-1),y)&TEXT(INDEX(A2:A14,z),"\-dd/mm/yyyy"),y&TEXT(INDEX(A2:A14,z),"\, dd/mm/yyyy")))))

答案2

在我看来，为这个问题编写一个 UDF 比发明一个可行但难以理解和编辑的长公式要容易一些。

该功能可以非常简单，例如：

Function getListAsString(aData As Range) As String
Dim aTemp As Variant
    aTemp = getSortedValuesFromRange(aData)
    getListAsString = getListOfDateRngsAsString(aTemp)
End Function

由于源数据可能未排序，函数的第一行将作为参数传递的范围转换为已排序的数组。

第二行分析这个值数组并形成结果字符串。

getSortedValuesFromRange()最终结果getListOfDateRngsAsString()将取决于您对 VBA 编程的准备程度和您的聪明才智。我的代码版本如下所示：

Private Function getSortedValuesFromRange(aData As Range) As Variant
Dim oCell As Range
Dim aResult As Variant
Dim vDate As Double, sFormattedDate As String
    aResult = Array()
    For Each oCell In aData.Cells
        sFormattedDate = Trim(oCell.Text)
        If sFormattedDate <> vbNullString Then
            vDate = oCell.value
            Call AddOrReplace(vDate, sFormattedDate, aResult)
        End If
    Next oCell
    getSortedValuesFromRange = aResult
End Function

Private Function getListOfDateRngsAsString(aData As Variant) As String
Dim aResult As Variant, sResult As Variant
Dim i As Long, j As Long
Dim prevDate As Variant, sPrevDate As String
    If UBound(aData) < LBound(aData) Then Exit Function
    ReDim aResult(0 To UBound(aData), 1 To 2)
    aResult(0, 1) = LBound(aData)
    aResult(0, 2) = LBound(aData)
    j = 0
    For i = LBound(aData) + 1 To UBound(aData)
        If aData(i)(0) - aData(aResult(j, 2))(0) > 1 Then
            j = j + 1
            aResult(j, 1) = i
            aResult(j, 2) = i
        Else
            aResult(j, 2) = i
        End If
     Next i
    sResult = aData(aResult(0, 1))(1)
    If aResult(0, 1) <> aResult(0, 2) Then sResult = sResult & "-" & aData(aResult(0, 2))(1)
     For i = 1 To j
        sResult = sResult & ", "
        If aResult(i, 1) = aResult(i, 2) Then
            sResult = sResult & aData(aResult(i, 1))(1)
        Else
            sResult = sResult & aData(aResult(i, 1))(1) & "-" & aData(aResult(i, 2))(1)
        End If
     Next i
    getListOfDateRngsAsString = sResult
End Function

Private Sub AddOrReplace(key, value, aData)
Dim l&, r&, m&, N&, i&
    l = LBound(aData)
    r = UBound(aData) + 1
    N = r
    While (l < r)
        m = l + Int((r - l) / 2)
        If aData(m)(0) < key Then l = m + 1 Else r = m
    Wend
    If r = N Then
        ReDim Preserve aData(0 To N)
        aData(N) = Array(key, value)
    ElseIf aData(r)(0) = key Then
        aData(r)(1) = value
    Else
        ReDim Preserve aData(0 To N)
        For i = N - 1 To r Step -1
            aData(i + 1) = aData(i)
        Next i
        aData(r) = Array(key, value)
    End If
End Sub

在单元格中写入=getListAsString(A1:A30)并获取结果

1/2/2023-4/2/2023, 6/2/2023-8/2/2023, 10/2/2023, 12/2/2023-13/2/2023, 16/2/2023-17/2/2023, 20/2/2023, 25/2/2023

相关内容