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 0End 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 = FalseEnd Sub

• \$\begingroup\$Welcome to Code Review! The current question title, which states your concerns about the code, is too general to be useful here. Pleaseedit to the site standard, which is for the title to simply statethe task accomplished by the code. Please seeHow to get the best value out of Code Review: Asking Questions for guidance on writing good question titles.\$\endgroup\$

  Toby Speight

  – Toby Speight

  2018-11-08 16:27:00 +00:00

  CommentedNov 8, 2018 at 16:27
• \$\begingroup\$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 thepurpose of this code?\$\endgroup\$

  Toby Speight

  – Toby Speight

  2018-11-08 16:27:51 +00:00

  CommentedNov 8, 2018 at 16:27
• \$\begingroup\$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.\$\endgroup\$

  TinMan

  – TinMan

  2018-11-08 18:16:43 +00:00

  CommentedNov 8, 2018 at 18:16

2 Answers2

Start asking to get answers

Find the answer to your question by asking.

Explore related questions

See similar questions with these tags.