# Speed up array loop vba Excel

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

• 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 Nov 8 '18 at 16:27
• 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? – Toby Speight Nov 8 '18 at 16:27
• 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. – TinMan Nov 8 '18 at 18:16

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.

• Sorry William but I already thought of that. Edited the post thought. Thanks – Damian Nov 8 '18 at 15:48

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.

• 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. – TinMan Nov 9 '18 at 11:46