Excel VBA日期分组宏优化：处理日期间隔、空行与跨月拆分

此为Stack Overflow线程续篇

我对最终版宏做了小幅修改，当前代码如下：

Sub GrupingByUser_pop()  
    Dim ws As Worksheet, lastR As Long, arr, arrIt, arrFin, firstDate As Date, lastDate As Date  
    Dim i As Long, j As Long, dict As Object    

    Set ws = ActiveSheet  
    lastR = ws.Range("D" & ws.Rows.Count).End(xlUp).Row 'last row on D:D    

    arr = ws.Range("A1:D" & lastR).Value 'place the range in an array for faster iteration    

    Set dict = CreateObject("scripting.Dictionary")     
    'set the necessary dictionary  
    For i = 1 To UBound(arr)  
        'if the first columns concatenation does not exist as a key, add it to dictionary:  
        If Not dict.Exists(CStr(arr(i, 1)) & "|" & arr(i, 2) & "|" & arr(i, 3)) Then  
            dict.Add CStr(arr(i, 1)) & "|" & arr(i, 2) & "|" & arr(i, 3), Array(arr(i, 4)) 'the item placed in an array  
        Else  
            arrIt = dict(CStr(arr(i, 1)) & "|" & arr(i, 2) & "|" & arr(i, 3)) 'extract the existing item in an array  
            ReDim Preserve arrIt(UBound(arrIt) + 1)                           'redim the item array preserving existing  
            arrIt(UBound(arrIt)) = arr(i, 4)                                  'place the date as the last array element  
            dict(CStr(arr(i, 1)) & "|" & arr(i, 2) & "|" & arr(i, 3)) = arrIt 'place the array back as the dict item  
        End If  
    Next i    

    'redim the final array:  
    ReDim arrFin(1 To dict.Count, 1 To 4)    

    'process the dictionary data and place them in the final array:  
    For i = 0 To dict.Count - 1  
        arrIt = Split(dict.keys()(i), "|") 'split the key by "|" separator  
        For j = 0 To UBound(arrIt): arrFin(i + 1, j + 1) = arrIt(j): Next j   'place each element in its column  

        firstDate = MakeDateFromStr(CStr(dict.Items()(i)(0))) 'extract first date  
        arrIt = dict.Items()(i)  
        lastDate = MakeDateFromStr(CStr(arrIt(UBound(arrIt)))) 'last date  
        If Month(firstDate) = Month(lastDate) Then 'if both date are inside the same month:  
           If lastDate = firstDate Then            
                'if only one date:  
                arrFin(i + 1, 4) = firstDate  
           Else                                    
                'if more dates (in the same month)  
                arrFin(i + 1, 4) = Format(Day(firstDate), "00") & " - " & Format(lastDate, "dd.mm.yyyy")  
           End If  
        Else                                        'if not in the same month:  
           arrFin(i + 1, 4) = Format(firstDate, "dd.mm.yyyy") & " - " & Format(lastDate, "dd.mm.yyyy")  
        End If  
    Next i    

    'drop the processed array result, at once:  
    Range("P1:T600").ClearContents  
    ws.Range("P1").Resize(UBound(arrFin), UBound(arrFin, 2)).Value = arrFin    

    'sort the range P1:T600 alphabetically by column P  
    With ws.Sort  
        .SortFields.Clear  
        .SortFields.Add Key:=ws.Range("P1:P600"), Order:=xlAscending  
        .SetRange ws.Range("P1:T600")  
        .Header = xlNo  
        .Apply  
    End With  
End Sub

Function MakeDateFromStr(d As String) As Date  
   MakeDateFromStr = CDate(Mid(d, 4, 2) & "/" & Left(d, 2) & "/" & Right(d, 4))  
End Function

该宏可基于多列数据为特定人员分组日期，并以「起始-结束」格式保存结果。但目前存在功能缺陷，需优化实现以下需求：

• 若某人员的日期序列存在间隔，需拆分生成多行独立日期区间；
• 跳过数据间的空行，解决当前宏因空行触发错误13的问题；
• 当月度切换时，自动将日期分组拆分为独立区间。

D列日期为文本格式，宏输出格式为dd/mm/yyyy（单日期）或dd-dd/mm/yyyy（同月多日期，欧盟格式），示例如下：

数据：
![输入数据示例]

结果：
![预期结果示例]

我保留了结果列的日期对齐格式，以便直观区分单天与分组区间。

内容的提问来源于stack exchange，提问作者KMYozz