加速数组循环 vba Excel

我一直在寻找网络和这个论坛，但我似乎无法找到解决我的问题的方法。

我有一个包含这些数据的表：

编辑代码

我有这个代码：

Sub HorariosReal()

    Dim LastRow As Long, Horario As String, i As Long, arr1 As Variant, a As Long, arrFichajes() As String, _
    arrFinal() As String, Valor1 As Single, Valor2 As Single, x As Long, y As Long, Done As Boolean

    Set YaHecho = New Scripting.Dictionary

    'Primero metemos en un array la gente con horario
    LastRow = ws2.Range("A1").End(xlDown).Row
    arr1 = ws2.Range("A2:A" & LastRow).Value2

    'Convertimos a valores los datos de fichajes y los reemplazamos
    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    With ws.Range("F2:J" & LastRow)
        .FormulaR1C1 = "=IFERROR(VALUE(RC[-5]),RC[-5])"
        .Value = .Value
        .Cut Destination:=ws.Range("A2")
    End With

    'Miramos si tiene programación
    With ws.Range("F2:F" & LastRow)
        .FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-4],Horarios!C1:C37,MATCH(Fichajes!RC[-5],Horarios!R1C1:R1C37,0),FALSE),""No aparece en programación"")"
        .Value = .Value
    End With

    'metemos los datos en un array
    ReDim arrFichajes(2 To LastRow, 1 To 6)
    ReDim arrFinal(2 To LastRow, 1 To 5)
    For i = 2 To UBound(arrFichajes, 1)
        For a = 1 To UBound(arrFichajes, 2)
            arrFichajes(i, a) = ws.Cells(i, a)
            If a = 3 Or a = 4 Then arrFichajes(i, a) = Format(ws.Cells(i, a), "hh:mm")
            If a = 5 Then
                Valor1 = Application.Round(ws.Cells(i, a), 2)
                arrFichajes(i, a) = Valor1
            End If
        Next a
    Next i

    x = 2
    y = 2
    For i = 2 To UBound(arrFichajes, 1)            
        Horario = arrFichajes(i, 3) & "-" & arrFichajes(i, 4)
        Valor1 = arrFichajes(i, 5)
        Done = CompruebaDiccionario(arrFichajes(i, 1) & arrFichajes(i, 2))
        If Done Then
            arrFinal(Llave, 3) = arrFinal(Llave, 3) & "/" & Horario
            Valor1 = arrFinal(Llave, 5)
            Valor2 = arrFichajes(i, 5)
            Valor1 = Valor1 + Valor2
            arrFinal(Llave, 5) = Valor1
        Else
            arrFinal(x, 1) = arrFichajes(i, 1)
            arrFinal(x, 2) = arrFichajes(i, 2)
            arrFinal(x, 3) = Horario
            arrFinal(x, 4) = arrFichajes(i, 6)
            arrFinal(x, 5) = Valor1
            YaHecho.Add y, arrFinal(x, 1) & arrFinal(x, 2)
            y = y + 1
            x = x + 1
        End If
    Next i

    ws.Range("A2:E" & LastRow).ClearContents
    ws.Range("A2:E" & UBound(arrFinal, 2)).Value = arrFinal

    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    With ws.Range("F2:F" & LastRow)
        .FormulaR1C1 = "=IFERROR(VALUE(RC[-1]),RC[-1])"
        .Value = .Value
        .Cut Destination:=ws.Range("E2")
    End With

End Sub

添加了这个函数来循环字典：

Function CompruebaDiccionario(Ejemplo As String) As Boolean

    Dim Key As Variant
    For Each Key In YaHecho.Keys
        If YaHecho(Key) = Ejemplo Then
            CompruebaDiccionario = True
            Llave = Key
            Exit For
        End If
    Next Key    

End Function

ID 只是一个示例，但问题是一个 ID（B 列）可以在同一天（A 列）有多个条目（C 列和 D 列）。

这是来自工人的数据，他们的输入（C 列）和输出（D 列）来自他们的工作，我需要将同一天一名工人的所有条目合并为一行（在 C 列上），然后在 D 列中找到他的时间表。

代码运行正常，但速度非常慢。我注意到如果我继续停止代码，它会变得更快（¿？¿？这可能吗）。

我决定使用数组，因为这是一个星期，它有 35k + 行，但仍然需要很长时间才能结束。

我要问的是我的代码是否有问题会减慢进程。任何帮助，将不胜感激。

谢谢！

编辑：

在调用这个之前，我正在使用这个子：

Sub AhorroMemoria(isOn As Boolean)

    Application.Calculation = IIf(isOn, xlCalculationManual, xlCalculationAutomatic)
    Application.EnableEvents = Not (isOn)
    Application.ScreenUpdating = Not (isOn)
    ActiveSheet.DisplayPageBreaks = False

End Sub