请测试下一个代码。它应该非常快，使用数组，提取唯一的人（使用字典），组的第一个范围，最后一个和它的最后一个结束时间，然后处理获得的字典/数组：

Sub groupPersons()
  Dim sh As Worksheet, lastR As Long, arr, arrInt, i As Long, j As Long
  Dim rngIns As Range, k As Long, dict As Object
  
  Set sh = ActiveSheet
  lastR = sh.Range("A" & sh.rows.count).End(xlUp).Row
  
  Set dict = CreateObject("Scripting.Dictionary")
  arr = sh.Range("A1:C" & lastR).Value2
  For i = 2 To UBound(arr)
        If Not dict.Exists(arr(i, 1)) Then
            dict.Add arr(i, 1), Array(i, i, arr(i, 3))
        Else
            arrInt = dict(arr(i, 1))
            arrInt(1) = i: arrInt(2) = arr(i, 3)
            dict(arr(i, 1)) = arrInt
        End If
  Next i
  'Stop
  For i = 0 To dict.count - 1
        addToRange rngIns, sh.Range("A" & dict.Items()(i)(0))
  Next i
  
  rngIns.EntireRow.insert xlDown
  arr = sh.Range("A1:E" & lastR + dict.count).Value2
  Dim ar: ar = arr
  For i = 2 To UBound(arr)
        If arr(i, 1) = "" Then
            ar(i, 1) = arr(i + 1, 1): ar(i, 2) = arr(i + 1, 2)
            ar(i, 3) = dict(ar(i, 1))(2): ar(i, 4) = arr(i + 1, 4)
            ar(i, 5) = arr(i + 1, 5)
        End If
  Next i
  Stop
  sh.Range("A1").Resize(UBound(ar), 5).Value2 = ar: Stop
  'Group rows:
  For i = 2 To UBound(arr)
     If arr(i, 1) = "" Then
        sh.rows(i + 1 & ":" & i + (dict(ar(i, 1))(1) - dict(ar(i, 1))(0) + 1)).group
      End If
  Next i  
End Sub

Sub addToRange(rngU As Range, rng As Range)
    If rngU Is Nothing Then
        Set rngU = rng
    Else
        Set rngU = Union(rngU, rng)
    End If
End Sub

我没有注解代码，因为我现在需要离开我的办公室。如果它按照你的需要工作，想要更好地理解它，我也会在回家后（几个小时后）注解它
请在测试后发送一些反馈。