How can i extract the correct leave time on this code? Excel VBA

Question

I've been trying to modify this code to extract the correct leave time but have been unable to do so

Sub ENTRADAS_SAIDAS()
    
    Application.ScreenUpdating = False

    'Beginning
 
    Range("A1").Select
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    ActiveWindow.Zoom = 85
    ActiveWindow.DisplayGridlines = False
    Range("A2").Select
    Selection.End(xlUp).Select
    Selection.End(xlToRight).Select
    Rows("1:1").Select
       
    
    'Concatenate Labortype with Employee#
   
    ActiveCell.Offset(0, 1).Columns("A:A").EntireColumn.Select
    Selection.Insert Shift:=xlToRight
    ActiveCell.Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[4],""-"",RC[3])"
    ActiveCell.Select
    Selection.Copy
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, -1).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.Columns("A:A").EntireColumn.Select
    ActiveCell.Activate
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
        
    'Concatenate Name with Surname & delete unnecessary columns
    
    ActiveCell.Offset(0, 1).Columns("A:A").EntireColumn.Select
    Selection.Insert Shift:=xlToRight
    ActiveCell.Offset(1, 1).Range("A1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, -1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=+CONCATENATE(RC[1],"" "",RC[2])"
    ActiveCell.Select
    Selection.Copy
    Range(Selection, Selection.End(xlUp)).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveCell.Columns("A:A").EntireColumn.Select
    ActiveCell.Activate
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    
    'Extract CC & format entry time
            
    ActiveCell.Offset(0, 1).Columns("A:D").EntireColumn.Select
    ActiveCell.Offset(0, 1).Range("A1").Activate
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    ActiveCell.Columns("A").EntireColumn.Select
    ActiveCell.Activate
    Selection.Insert Shift:=xlToRight
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    Selection.End(xlToRight).Select
    ActiveCell.Offset(0, -1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IFERROR(VALUE(MID(RC[-1],5,4)),MID(RC[-1],5,4))"
    ActiveCell.Activate
    Selection.Copy
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.Columns("A:A").EntireColumn.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.End(xlUp).Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "CC"
    ActiveCell.Offset(0, -1).Columns("A:A").EntireColumn.Select
    Selection.Delete Shift:=xlToLeft
    Selection.End(xlToRight).Select
    ActiveCell.Columns("A:A").EntireColumn.Select
    Selection.NumberFormat = "dd/mm/yy hh:mm;@"
    Range("A1").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.AutoFilter


    'Extract leaving time

    ActiveCell.Select
    Selection.End(xlToRight).Select
    ActiveCell.FormulaR1C1 = "Entrada"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Saída"
    Columns("A:G").EntireColumn.Select
    Selection.AutoFilter Field:=5, Criteria1:=Array( _
        "*TOR*SA*DA*"), Operator:= _
        xlFilterValues
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Application.Goto Reference:="R10000C1"
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A2").Select
    Rows("2:2").EntireRow.Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Delete Shift:=xlUp
    ActiveSheet.ShowAllData
    Range("A2").Select
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.End(xlDown).Select
    Selection.End(xlToRight).Select
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "=+VLOOKUP(RC2,R9000C2:R20000C7,5,FALSE)"
    ActiveCell.Select
    Selection.Copy
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("A2").Select
    Selection.End(xlUp).Select
    Selection.End(xlToRight).Select
    ActiveCell.FormulaR1C1 = "Saída"
    ActiveCell.Columns("A:A").EntireColumn.Select
    ActiveCell.Offset(1, 0).Range("A1").Activate
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A2").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Application.CutCopyMode = False
    Selection.EntireRow.Delete
    Rows("1:1").Select
    Selection.Font.Bold = True
    Range("A2").Select
    ActiveCell.Columns("E:E").EntireColumn.Delete
    ActiveCell.Columns("A:F").EntireColumn.AutoFit
    
    
    'Conditional format for records with the same name
    
    ActiveCell.Columns("C:C").EntireColumn.Select
    ActiveCell.Activate
    Selection.FormatConditions.AddUniqueValues
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    Selection.FormatConditions(1).DupeUnique = xlDuplicate
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False

       
    'Dates formating
    
    Range("M2").Select
    ActiveCell.FormulaR1C1 = "=VALUE(TEXT(RC[-8],""aaaa-m-dd h:mm""))"
    Selection.Copy
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.Offset(0, -1).Range("A1:B1").Select
    ActiveCell.Activate
    Selection.Copy
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 7).Range("A1:B1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Copy
    Selection.End(xlToLeft).Select
    ActiveCell.Offset(0, -1).Range("A1").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "d/m/yy h:mm;@"
    ActiveCell.Offset(0, 8).Columns("A:B").EntireColumn.Select
    Selection.Delete Shift:=xlToLeft


    'OT Business Day % Formula input
    
    Range("A2").Select
    Selection.End(xlToRight).Select
    ActiveCell.Offset(-1, 1).Activate
    ActiveCell = "OT BusDay %"
    ActiveCell.Offset(1, 0).Activate
    ActiveCell.FormulaR1C1 = "=+((RC[-1]-RC[-2])*24-0.5)/8"
    Selection.Copy
    ActiveCell.Offset(0, -1).Activate
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 1).Activate
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Columns("G:G").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A2").Select
    ActiveCell.Offset(0, 3).Columns("A:A").EntireColumn.Select
    Selection.Cut
    ActiveCell.Offset(0, -2).Columns("A:A").EntireColumn.Select
    Selection.Insert Shift:=xlToRight
    Range("A2").Select

    Application.ScreenUpdating = True

End Sub

This code works well if a employee enters multiple times however if someone leaves multiple times it ONLY displays the first leaving time

So far i've been unable to change this,that's why im asking for help here any kind of tips would be immensely appreciated!

Im going to put 2 images in this post the first one is the type of data we are supposed to copy and then paste before using the macro and the second one is the result (ill circle around the problem i have with the leave times)

So Grazielle can enter at 19:57 and leave at 19:54? multiple times is not the problem, but time travel IS... — Solar Mike, Aug 30 '23 at 12:00
the thing is though that none of them have negative results,all of the leave times appear in the information block we are supposed to paste onto the file but when we run the macro that's when it doesn't take the leave times into account and only puts the first leave time onto column F — Gonçalo, Aug 30 '23 at 12:10
This is a LOT of use of Select, try to [avoid Select](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) as much as possible. — Notus_Panda, Aug 30 '23 at 12:15
So, column G, a value of "-0.06875" for Graziella in not negative? we have a problem - one of us does not understand negatives... — Solar Mike, Aug 30 '23 at 12:17
I think he means his entries don't have negative values and that the VLOOKUP only gives the first found leave time (which is normal for a VLOOKUP to do) — Notus_Panda, Aug 30 '23 at 12:21
The column G in the second picture is the output of the macro = not the entry (negative values come from a formula based on the wrong exit-time). If you're suggesting to delete those rows, then you'd be avoiding the problem instead of addressing it, no? (also would be losing the data of someone entering/leaving again) @SolarMike — Notus_Panda, Aug 30 '23 at 13:13
@Notus_Panda especially when they leave before they enter :) really important data that, must be with Dr Who. — Solar Mike, Aug 30 '23 at 13:17
The issue is that the wrong exit-time is found, not that they leave before they arrived.. Not sure why you're a stickler for the time-travelling idea, you know that `VLOOKUP` gives the first found value. Now let's get back on track to helping OP @SolarMike — Notus_Panda, Aug 30 '23 at 13:24
So, I would be looking at other methods to calculate the values in column G, and there are ways of dealing with duplicate entries. This is one I use: https://stackoverflow.com/a/58640367/4961700 — Solar Mike, Aug 30 '23 at 13:29
I tried doing it by INDEX and perhaps im too stupid but i couldn't make it work it just returned the same thing on all the fields — Gonçalo, Aug 30 '23 at 14:47

Notus_Panda · Accepted Answer · 2023-08-31T15:21:13.303

I've tried simplifying things because there was a bunch of unnecessary code, I may have let myself go a bit overboard. There are commented lines but do let me know if there's something you don't understand.
Mostly worked with arrays and included a dictionary to couple the entries with the exits.

The entries are as follows (I tried to copy yours as good as possible)

With some leaving and entering more than once:

Option Explicit

Sub ENTRADAS_SAIDAS()
    
    'Application.ScreenUpdating = False

    'Beginning
 
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    ActiveWindow.Zoom = 85
    ActiveWindow.DisplayGridlines = False
    
    Dim lRow As Long
    lRow = Range("B" & Rows.Count).End(xlUp).Row 'every entry should at least have a name
    
    'Concatenate Labortype with Employee#
    Range("B1").EntireColumn.Insert Shift:=xlToRight
    
    Dim arr1, arr2, arrPrint
    arr1 = Range("F1:F" & lRow).Value
    arr2 = Range("E1:E" & lRow).Value
    ReDim arrPrint(1 To lRow, 1 To 1)
    
    Dim i As Long
    For i = 1 To lRow
        arrPrint(i, 1) = arr1(i, 1) & "-" & arr2(i, 1)
    Next i
    Range("B1:B" & lRow).Value = arrPrint
        
    'Concatenate Name with Surname
    With Range("C1:C" & lRow)
        arr1 = .Value
        arr2 = Range("D1:D" & lRow).Value
        For i = 1 To lRow
            arrPrint(i, 1) = arr1(i, 1) & " " & arr2(i, 1)
        Next i
        .Value = arrPrint
    End With
    
    'Extract CC & format entry time & delete unnecessary columns
            
    With Range("G1:G" & lRow)
        arr1 = .Value
        For i = 1 To lRow
            arrPrint(i, 1) = Mid(arr1(i, 1), 5, 4) 'getting the characters
        Next i
        .Offset(, -5).EntireColumn.Insert Shift:=xlToRight 'putting CC in B-column
        With .Offset(, -6)
            .NumberFormat = "General" 'forces value into number since we're working with .Value
            .Value = arrPrint
            .Cells(1, 1).Value = "CC"
        End With
    End With
    
    Range("E1:H1").EntireColumn.Delete Shift:=xlToLeft
    
    Range("F2:G" & lRow).NumberFormat = "dd/mm/yy hh:mm;@"
    Range("A1").AutoFilter
    
    With ActiveSheet.AutoFilter.Sort 'sorting the times
        .SortFields.Clear
        .SortFields.Add Key:= _
            Range("F1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    'Extract leaving time
    Range("E1").Value = "Entrada"
    Range("F1").Value = "Saída"
    
    Dim dict As Object, entrAmt As Long, rCounter As Long, j As Long
    Dim nameTrim As String, rPrint As Long
    
    Set dict = CreateObject("Scripting.Dictionary") 'for checking where the entrance-time is
    entrAmt = Application.CountIf(Range("E2:E" & lRow), "*ENTRA*")
    ReDim arrPrint(1 To entrAmt, 1 To 8)
    arr1 = Range("A2:F" & lRow).Value 'the entirity
    
    For i = 1 To lRow - 1
        nameTrim = Trim(arr1(i, 1) & arr1(i, 3) & arr1(i, 4)) 'Tipo+JobType+Number+Full Name
        If InStr(arr1(i, 5), "ENTRA") > 0 Then 'entry time
            rCounter = rCounter + 1
            For j = 1 To UBound(arrPrint, 2) - 3 'not times or calculated value
                arrPrint(rCounter, j) = arr1(i, j)
            Next j
            arrPrint(rCounter, 6) = CDate(arr1(i, 6))
            dict(nameTrim) = rCounter 'Name as Key with row in the arrPrint as Value
            'it should just add the key if it doesn't exist yet and overwrite if it does
        Else
            rPrint = dict(nameTrim)
            If rPrint > 0 Then 'To skip the exits without entry
                arrPrint(rPrint, 7) = CDate(arr1(i, 6)) 'exit time
                arrPrint(rPrint, 8) = ((arrPrint(rPrint, 7) - arrPrint(rPrint, 6)) * 24 - 0.5) / 8
                dict(nameTrim) = 0
            End If
        End If
    Next i
    
    Dim k
    For Each k In dict.Keys
        If dict(k) <> 0 Then arrPrint(dict(k), 8) = "No saida!" 'I'm just guessing this means exit, sorry
    Next k
    Set dict = Nothing
    
    With Range("A2:H" & entrAmt + 1)
        .Value = arrPrint
        .Offset(entrAmt).Resize(lRow - entrAmt - 1).EntireRow.Delete
    End With
    Range("E1").EntireColumn.Delete Shift:=xlToLeft
    Range("A1:G1").EntireColumn.AutoFit
    
    Application.ScreenUpdating = True

End Sub

With the end result:

Hope that helps, I know it might not be exactly as you had it but your F-column in entry was cut off already so did what I could ^^

That honestly looks great,and i feel like its much easier to read than the other code i was given! the thing is though (and perhaps im not running this correctly) that im getting a type mismatch error when i run the macro Basically im copying everything from column A,B,C,D,E,F,G,H and pasting it onto the file with the macro,after its pasted i run the macro and i get a type mismatch error on this line arrPrint(rPrint, 8) = ((arrPrint(rPrint, 7) - arrPrint(rPrint, 6)) * 24 - 0.5) / 8 — Gonçalo, Aug 31 '23 at 07:06
Can you check what the values are at the time of the error? `rPrint`, `arrPrint(rPrint,7)` and `arrPrint(rPrint,6)` you can check when hovering over them. Unless it's not a proper input date-time wise, there shouldn't be an issue unless rPrint has an incorrect value somehow. I didn't do the conversion of your dates with `=VALUE(TEXT(RC[-8],""aaaa-m-dd h:mm""))` so there might be something screwy with that since I gave it in as you had it and excel understood it as a proper date-time value. — Notus_Panda, Aug 31 '23 at 07:19
the values that im getting are rPrint = 190, arrPrint(rPrint,7) = "2023-07-08 16:36:08" and arrPrint(rPrint, 6) = "2023-07-08 16:19:49" — Gonçalo, Aug 31 '23 at 07:26
I tried running your macro with some other values and it still gave me the error on the same line (although different times ofc) — Gonçalo, Aug 31 '23 at 07:30
Alrighty, made a small edit, namely the addition with `CDate()` over the two dates. Tested with both `` — Notus_Panda, Aug 31 '23 at 08:00
Alrighty, made a small edit, namely the addition with `CDate()` over the two dates. Tested with both text versions "2023-07-08 16:30:25" and "08/07/2023 16:30:25" and they both converted properly. Try out the edited code and see if that fixed the issue. Sorry, hit enter too quick and before editing it properly noticed a negative value on the sheet but must've been a mistake when testing the text-versions (no negative values the second time I redid the text). — Notus_Panda, Aug 31 '23 at 08:07
I ran the updated version and still got an error but not on the same line of code now i got an error on arrPrint(rPrint, 7) = CDate(arr1(i, 6)) 'exit time. BTW CDate(arr1(i, 6)) = 08/07/2023 17:34:47 I have no idea why this is happening,checked to see if my data had any blank spots or negative text but it has neither hmmm. Also thank you alot for taking time to help me out,i really appreciate it — Gonçalo, Aug 31 '23 at 08:17
Let us [continue this discussion in chat](https://chat.stackoverflow.com/rooms/255124/discussion-between-notus-panda-and-goncalo). — Notus_Panda, Aug 31 '23 at 08:30

CDP1802 · Answer 2 · 2023-08-31T15:25:32.530

If you first sort the data you could scan down identifying the entry time for each exit.

Option Explicit

Sub ENTRADAS_SAIDAS2()

    Dim ws As Worksheet, lastrow As Long, lastcol As Long
    Dim rng As Range, cc As String
    Dim r As Long, n As Long, e As Long
    Dim colB As String, colC As String, colD As String
      
    Set ws = ActiveSheet
    With ws
        lastrow = .UsedRange.Rows.Count
        
        ' sort my numero, data
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("D1"), _
           SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("H1"), _
           SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange ws.UsedRange
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        ' columns headings
        .Range("B1:D1") = Array("CC", "JobType-Numero Empragado", "Name Apelido")
        .Range("H1:J1") = Array("Entrada", "Saida", "OT BusDay %")
        ' OT BusDay calc
        .Range("J2:J" & lastrow).FormulaR1C1 = "=IF(RC[-1]>0,((RC[-1]-RC[-2])*24-0.5)/8,"""")"
        
        ' scan down for exits with same person entry on previous line
        r = 2
        Do While r <= lastrow
            
            ' combine
            colB = Mid(.Cells(r, "F"), 5, 4) ' cc
            colC = .Cells(r, "E") & " " & .Cells(r, "D") ' JobType-Numero
            colD = .Cells(r, "B") & " " & .Cells(r, "C") ' name apelida
            
            .Cells(r, "B") = colB
            .Cells(r, "C") = colC
            .Cells(r, "D") = colD
        
            ' exits - is previous record same person AND an entry
            If .Cells(r, "G") Like "*SAIDA*" Then
                If .Cells(r - 1, "C") = .Cells(r, "C") _
                   And .Cells(r - 1, "G") Like "*ENTRA*" Then
                
                    ' copy time into Saida
                    .Cells(r - 1, "I") = .Cells(r, "H")
                Else
                    e = e + 1
                End If
               
                ' delete saida rows later
                If rng Is Nothing Then
                    Set rng = .Cells(r, "A")
                Else
                    Set rng = Application.Union(rng, .Cells(r, "A"))
                End If
                n = n + 1
            End If
            r = r + 1
        Loop
        
        'Conditional format for records with the same name
        With .Columns("D:D").EntireColumn
            .FormatConditions.AddUniqueValues
            .FormatConditions(1).SetFirstPriority
            .FormatConditions(1).DupeUnique = xlDuplicate
            With .FormatConditions(1).Font
                .Color = -16383844
                .TintAndShade = 0
            End With
        
            With .FormatConditions(1)
                With .Interior
                    .PatternColorIndex = xlAutomatic
                    .Color = 13551615
                    .TintAndShade = 0
                End With
                .StopIfTrue = False
            End With
        End With
        
        ' format columns
        .Columns("E:G").Delete
        .Columns("E:F").NumberFormat = "aaa-m-dd h:mm"
        .Columns("G:G").NumberFormat = "0.00"
        .Columns("A:G").AutoFit
        
    End With
    
    ' delete exit rows
    If n > 0 Then
       'rng.Interior.Color = vbRed
       rng.EntireRow.Delete
    End If
        
    MsgBox n & " rows deleted" & vbLf & _
           e & " exits without entry", vbInformation
End Sub

Interesting to know that the sorting works in the opposite order of input, i.e. H-column gets sorted first and then the D-column (if I'm understanding it correctly). — Notus_Panda, Aug 31 '23 at 14:22
That's what I mean, it's added first but sorted last, right? Otherwise it'd have fumbled up all the names again if it did the names first and then the times. — Notus_Panda, Aug 31 '23 at 14:40
@Notus_Panda not names, it is suppose to sort on employee numbers then the times. I assumed the numbers were unique to the person unlike the name. — CDP1802, Aug 31 '23 at 14:45
Oh my bad, I meant numbers ye. But how do they stick together then if it does the numbers first and then the times? Is it because you added the keys before applying the sorting? — Notus_Panda, Aug 31 '23 at 14:54
@Notus_Panda Yes, add the keys in order and then `.Apply`, To be honest I recorded that bit as a macro ! — CDP1802, Aug 31 '23 at 15:00
Just fyi, OP had an issue with the sort, namely his version is 2016 and the `.Add2` was throwing an error, using `.Add` instead seemed to have fixed it. — Notus_Panda, Aug 31 '23 at 15:22

How can i extract the correct leave time on this code? Excel VBA

2 Answers2