对行中的日期进行分组

Question

我有这样的信息/数据：

如果日期是连续的，如何将给定员工的日期从多行分组为一行？

我尝试了人工智能，但我在格式化日期和写入日期方面仍然存在问题，而且我无法更改它，因为它是先前操作的结果。

• 宏将在活动工作表中运行，
• 仅适用于 A-D 列
• 结果会传送到P-S列，需要先清除
• 我的数据没有标题
• 具有单个日期的行保持原样
• 适用于小型办公室的 MS Office 2016

我想要：

Answer 1

请尝试下一个代码。它使用字典和一些数组。主要在内存中工作并仅删除处理后的数组结果，即使对于大范围，它也应该非常快。它假设 对于同一用户，A、B 和 C 列中的所有数据都相同：

Sub GrupingByUser()
  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:
  ws.Range("P1").Resize(UBound(arrFin), UBound(arrFin, 2)).Value = arrFin
  
  MsgBox "Ready..."
End Sub

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

我尝试对每一行代码进行注释，所以我认为它应该很容易理解。如果有些事情不够清楚，请随时要求澄清。

CStr(arr(i, 1))

已用于克服第一列 (

#N/A

) 中的潜在错误。即使它们被写为字符串，VBA 仍然将它们理解为错误（例如，#N/A 被理解为错误 2024）。写成#N/A很容易，但我认为没有必要......

请在测试后发送一些反馈。