Speed up array loop vba Excel

Question

I've got here from stackoverflow

I have a table with this data:

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

• Toby Speight: Welcome to Code Review! The current question title, which states your concerns about the code, is too general to be useful here. Please edit to the site standard, which is for the title to simply state the task accomplished by the code. Please see How to get the best value out of Code Review: Asking Questions for guidance on writing good question titles.
• Toby Speight: Additionally, it's not clear what your code is intended to do - there's no description, and the names/comments are not in English. What's the purpose of this code?
• TinMan: Using dictionaries for lookups and arrays for the data you could process the 35k rows in about 3 seconds or less. You will need to store all the information in arrays and have the dictionaries store the indices of the key values that you are looking up.

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.

• Damian: Sorry William but I already thought of that. Edited the post thought. Thanks

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.

• TinMan: Bravo! Much Better. On a side note: I don't think that .FormulaR1C1 = "=VALUE(RC[-" & x + 1 & "])" is needed. .Value = .Value should convert the text to dates.