Speed up array loop vba Excel

Question

I've got here from stackoverflow

I have a table with this data:

I have this code:

Sub HorariosReal()

    Dim LastRow As Long, Horario As String, i As Long, arr1 As Variant, Comprueba As Variant, a As Long, arrHechos() As String, _
    YaHecho As Variant, arrFichajes() As String, arrFinal() As String


    'Insert people with schedule into one array
    LastRow = ws2.Range("A1").End(xlDown).Row
    arr1 = ws2.Range("A2:A" & LastRow).Value2

    'some tweaking for the data
    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

    'Insert data into one array
    ReDim arrFichajes(0 To LastRow, 0 To 4)
    For i = 0 To UBound(arrFichajes, 1)
        For a = 0 To UBound(arrFichajes, 2)
            arrFichajes(i, a) = ws.Cells(i + 2, a + 1)
            If a = 2 Or a = 3 Then arrFichajes(i, a) = Format(ws.Cells(i + 2, a + 1), "hh:mm") 'just need a string
            If a = 4 Then arrFichajes(i, a) = Application.Round(ws.Cells(i + 2, a + 1), 2) 'round the number because vba gives wrong numbers later
        Next a
    Next i

    ReDim arrHechos(0 To 0) 'to keep the ones already done
    ReDim arrFinal(0 To 4, 0 To 0) 'final array with clean data
    On Error Resume Next 'i'm expecting people without schedule so it will throw errors
    For i = 0 To UBound(arrFichajes, 1)
        Horario = Format(arrFichajes(i, 2), "hh:mm") & "-" & Format(arrFichajes(i, 3), "hh:mm") 'Columns C and D
        YaHecho = Application.Match(arrFichajes(i, 0) & arrFichajes(i, 1), arrHechos, 0) 'check if already exists so I can update his schedule
        If IsError(YaHecho) Then 'if doesn't exists, fill a new line on the final array
            arrFinal(0, UBound(arrFinal, 2)) = arrFichajes(i, 0) 'Column A
            arrFinal(1, UBound(arrFinal, 2)) = arrFichajes(i, 1) 'Column B
            arrFinal(2, UBound(arrFinal, 2)) = Horario 'Column C + D
            arrFinal(3, UBound(arrFinal, 2)) = ws2.Cells(ws2.Cells.Find(arrFichajes(i, 1)).Row, Day(arrFichajes(i, 0) + 6)) 'here we look for his schedule.
            If arrFinal(3, UBound(arrFinal, 2)) = vbNullString Then arrFinal(3, UBound(arrFinal, 2)) = "No aparece en programación" 'if doesn't have schedule we mark it.
            arrFinal(4, UBound(arrFinal, 2)) = arrFichajes(i, 4) 'Column E
            If arrHechos(UBound(arrHechos)) <> vbNullString Then ReDim Preserve arrHechos(0 To UBound(arrHechos) + 1) 'add one row to the array
            arrHechos(UBound(arrHechos)) = arrFinal(0, UBound(arrFinal, 2)) & arrFinal(1, UBound(arrFinal, 2)) 'fill the last row to keep up the ones i've done
            ReDim Preserve arrFinal(0 To 4, 0 To UBound(arrFinal, 2) + 1) 'add a row to the final array with clean data
        Else 'if already exists
            YaHecho = YaHecho - 1 ' application.match starts on 1 and my array on 0, so need to balance
            arrFinal(2, YaHecho) = arrFinal(2, YaHecho) & "/" & Horario 'update the schedule
            arrFinal(4, YaHecho) = arrFinal(4, YaHecho) + arrFichajes(i, 4) 'add the hours worked
        End If
    Next i
    On Error GoTo 0
End Sub

The IDs are just a sample, but the thing is that one ID (Column B) can have multiple entries (Columns C and D) on the same day (Column A).

This is data from workers, their in (Column C) and outs (Column D) from their work, I need to merge all the entries from one worker on the same day in one row (on column C), then on column D find his schedule.

The code works ok, but extremely slow. I noticed that if I keep stopping the code, it goes faster (¿?¿? is this possible).

I decided to work with arrays because this is one week and it has 35k + rows, still it takes ages to end.

What I am asking is if there is something wrong on my code that slows down the process. Any help would be appreciated.

Thanks!

Edit:

I'm using this sub before this one is called:

Sub AhorroMemoria(isOn As Boolean)

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

End Sub

Answer 1

An easy win would be to disable screen updating. This will cause your script to run faster, as excel will not try and rerender as your macro runs. I've found this can speed up tasks that involve spreadsheet data insertion significantly. Be sure to re-enable screen updating if your script hits an error, otherwise it can be troublesome to turn on again.

Answer 2

Here is my answer, I finally managed to make it work! I wasn't using dictionary as it should be used.

This is the final code, worked 35k rows in 3s and 153k of rows in barely 18s.

Sub HorariosReal()

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

    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 las fechas de programación
    i = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
    x = i - 6
    With ws2.Range(ws2.Cells(1, i + 2), ws2.Cells(1, i + 1 + x))
        .FormulaR1C1 = "=VALUE(RC[-" & x + 1 & "])"
        .Value = .Value
        .Cut Destination:=ws2.Cells(1, 7)
    End With

    '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


    'Comprobamos si el DNI está en la primera columna
    If ws2.Range("A1") <> "DNI" Then
        ws2.Columns(3).Cut
        ws2.Columns(1).Insert Shift:=xlToRight
    End If

    '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 arrFinal(1 To LastRow, 1 To 5)
    arrFichajes = ws.Range("A2:F" & LastRow)

    x = 1
    y = 1
    For i = 1 To UBound(arrFichajes, 1)
        Horario = Format(arrFichajes(i, 3), "hh:mm") & "-" & Format(arrFichajes(i, 4), "hh:mm")
        Valor1 = arrFichajes(i, 5)
        Done = YaHecho.Exists(arrFichajes(i, 1) & arrFichajes(i, 2))
        If Done <> 0 Then
            Done = YaHecho(arrFichajes(i, 1) & arrFichajes(i, 2))
            arrFinal(Done, 3) = arrFinal(Done, 3) & "/" & Horario
            Valor1 = arrFinal(Done, 5)
            Valor2 = arrFichajes(i, 5)
            Valor1 = Valor1 + Valor2
            arrFinal(Done, 5) = Valor1
        Else
            arrFinal(x, 1) = Int(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 Key:=arrFinal(x, 1) & arrFinal(x, 2), Item:=y
            y = y + 1
            x = x + 1
        End If
        Done = 0
    Next i

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

    'Tenemos que arreglar las horas y fechas que se quedan como texto
    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    With ws.Range("G2:G" & LastRow) 'horas
        .FormulaR1C1 = "=IFERROR(VALUE(RC[-2]),RC[-2])"
        .Value = .Value
        .Cut Destination:=ws.Range("E2")
    End With

    With ws.Range("G2:G" & LastRow) 'fechas
        .FormulaR1C1 = "=IFERROR(VALUE(RC[-6]),RC[-6])"
        .Value = .Value
        .Cut Destination:=ws.Range("A2")
    End With

End Sub

Hope it helps someone.