VBA 字典 这样的考勤表该如何处理？

Sub GetData(control As IRibbonControl)
    Dim aData
    Dim Dic As Object
    Dim intX&, intY&, intC&, x&
    Dim strTime$, strMaxTime$, strMinTime$, strID$, strName$, strGroup$, strDate
    Dim Sht As Worksheet, T
    On Error Resume Next
    T = Timer
    Set Dic = CreateObject("Scripting.Dictionary") '后期绑定字典
    aData = Worksheets("原始考勤").Range("A1").CurrentRegion '获取数据源
    Dic(0) = Array("姓名", "工号ID", "部门", "考勤日期", "上班时间", "下班时间") '字典的条目为一个6个元素的一维数组
    For intX = LBound(aData) To UBound(aData) '遍历数据源
        If aData(intX, 1) Like "工号*" Then '判断数据源中第1列是否包含工号
            strID = aData(intX, 3): strName = aData(intX, 11): strGroup = aData(intX, 18) '工号ID,姓名,部门赋值
            intX = intX + 2 '数据源行位置+2
            intC = intX '赋值
            Do '累加计算每个员工在数据源中占了多少行位置
                intC = intC + 1
                If intC > UBound(aData) Then Exit Do
            Loop Until aData(intC, 1) Like "工号*"
            intC = intC - 1
            For intY = 1 To UBound(aData, 2) '遍历数据源列
                strTime = "" '初始化
                For x = intX To intC '遍历循环每个员工在数据源中所有内容
                    If aData(x, intY) <> "" Then
                        strTime = strTime & aData(x, intY) '当不为空时连接字符
                    End If
                Next
                If strTime <> "" Then
                    strTime = Replace(strTime, Chr(10), "") '替换换行符
                    strMinTime = Format(Left(strTime, 5), "hh:mm:ss") '获取左边5位字符,使用Format函数更改格式既上班时间
                    If Len(strTime) > 5 Then
                        strMaxTime = Format(Right(strTime, 5), "hh:mm:ss") '当字符长度超过5位时获取右边5位字符,既下班时间
                    Else
                        strMaxTime = ""
                    End If
                    strDate = "2021/5/" & intY '连接日期
                    Dic(strID & intY) = Array(strName, strID, strGroup, strDate, strMinTime, strMaxTime)
                    '关键使用员工ID+数据列位置作为Key,条目为一维数组,相关的元素包含了姓名,ID,部门,上下班时间,日期存入字典
                End If
            Next
            intX = intC'赋值循环行位置
        End If
    Next
    Set Sht = Worksheets("数据整理")
    If Err Then '发生错误代表不包含数据整理工作表
        Err.Clear
        With Sheets.Add(after:=Sheets(Sheets.Count)) '新建数据表
            .Name = "数据整理"
        End With
        Set Sht = Worksheets("数据整理")
    End If
    With Sht
        .Activate
        .Cells.Clear '为方便直接清空内容
        With .Range("a1").Resize(Dic.Count, 6)
            .Value = Application.Rept(Dic.items, 1) '使用Application.Rept输出字典中的Item
            .Borders.ColorIndex = 23 '添加边框
            .Columns.AutoFit '自适应列宽
        End With
        .Cells(2, 1).Select
        ActiveWindow.FreezePanes = True '冻结窗格
        ActiveWindow.DisplayGridlines = False '取消网格线
    End With
    Set Dic = Nothing '释放字典内存
    MsgBox "整理完毕,用时:" & Format(Timer - T, "0.000秒") '计算运行时长
End Sub