Hey guys, how are you?
Could you please help me to obtain the work hours between2 dates and improve my macro? I am not an expert and VBA is a little tricky :/
Take a look at this image:
https://imgur.com/a/ajPJoMz
Thanks
Hey guys, how are you?
Could you please help me to obtain the work hours between2 dates and improve my macro? I am not an expert and VBA is a little tricky :/
Take a look at this image:
https://imgur.com/a/ajPJoMz
Thanks
Why not just use a formula?
Assuming weekends get included
=(INT(E2-D2)*("18:00"-"09:00") +MEDIAN(MOD(E2,1),"18:00","09:00") -MEDIAN(MOD(D2,1),"18:00","09:00"))*24
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
I cannot see why you want a macro over a formula, but if you must, create some code to inject the formula, and then value it.
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
This code does it.
I have used all the constants so as to make it easy to amend if the start/end day times change. I have also output the answer as hh:mm as this makes more sense (to me) than decimals.Const WORKING_DAY_END As String = "18:00" Const FORMULA_WORKING_TIME As String = _ "=(INT(E2-D2)*(""" & WORKING_DAY_END & """-""" & WORKING_DAY_START & """)" & _ "+MEDIAN(MOD(E2,1),""" & WORKING_DAY_END & """,""" & WORKING_DAY_START & """)" & _ "-MEDIAN(MOD(D2,1),""" & WORKING_DAY_END & """,""" & WORKING_DAY_START & """))" Dim lastrow As Long With ActiveSheet lastrow = .Cells(.Rows.Count, "G").End(xlUp).Row With Range("G2").Resize(lastrow - 1) .Formula = FORMULA_WORKING_TIME .Value = .Value .NumberFormat = "[h]:mm" End With End With
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
There is a lot of code in that workbook. Post the workbook that yoi modified with your modification, and tell me how to trigger the thing you want.
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
Dude, check the image (https://imgur.com/a/ajPJoMz)
This is my code, it calculates the time between 2 dates BUT not the work hours. I tried to modify it but it did not work :/:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim LastRow
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
t1 = TimeValue(CStr(Cells(i, "D").Value))
t2 = TimeValue(CStr(Cells(i, "E").Value))
t3 = TimeValue(CStr(Cells(i, "F").Value))
'input First Response time
If Hour(t2) - Hour(t1) = 0 Then
Cells(i, "G").Value = Round((Minute(t2) - Minute(t1)) / 60, 2)
Else
Cells(i, "G").Value = Hour(t2) - Hour(t1) + Round((Minute(t2) - Minute(t1)) / 60, 2)
End If
'input Elapsed Time
If Hour(t3) - Hour(t1) = 0 Then
Cells(i, "H").Value = Round((Minute(t3) - Minute(t1)) / 60, 2) '- Cells(i, "J").Value - Cells(i, "J").Value
Else
Cells(i, "H").Value = Hour(t3) - Hour(t1) + Round((Minute(t3) - Minute(t1)) / 60, 2) '- Cells(i, "J").Value
End If
Next i
Target.Offset(1).Select
End Sub
If you post the workbook, and tell me how to trigger the thing you want, and I will look. I do not have time nor inclination to try and work it out from pictures and code snippets.
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
Well, it goes like this:
When you enter any date/time inside the field "Date of the problem" AND "Date first response" you should display the difference between both dates in the other field called "Date Last Response". I mean, double click any cell to input values.Finally, there is a field called "EXTRA TIME" and entering an 'Extra Time' value will adjust the Elapsed Time value AND Deleting an Extra Time' value will return the original Elapsed Time value.
Thats basically everything.
This is my WORKSHEET:
Public cVal Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim LastRow LastRow = Range("A" & Rows.Count).End(xlUp).Row For i = 2 To LastRow t1 = TimeValue(CStr(Cells(i, "D").Value)) t2 = TimeValue(CStr(Cells(i, "E").Value)) t3 = TimeValue(CStr(Cells(i, "F").Value)) 'input First Response time If Hour(t2) - Hour(t1) = 0 Then Cells(i, "G").Value = Round((Minute(t2) - Minute(t1)) / 60, 2) Else Cells(i, "G").Value = Hour(t2) - Hour(t1) + Round((Minute(t2) - Minute(t1)) / 60, 2) End If 'input Elapsed Time If Hour(t3) - Hour(t1) = 0 Then Cells(i, "H").Value = Round((Minute(t3) - Minute(t1)) / 60, 2) '- Cells(i, "J").Value - Cells(i, "J").Value Else Cells(i, "H").Value = Hour(t3) - Hour(t1) + Round((Minute(t3) - Minute(t1)) / 60, 2) '- Cells(i, "J").Value End If Next i Target.Offset(1).Select End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim i, LastRow LastRow = Range("C" & Rows.Count).End(xlUp).Row + 10 'adjust Extra Time If Target.Column = 10 Then If Target.Value <> "" Then Target.Offset(0, -2).Value = Target.Offset(0, -2).Value - Target.Value ElseIf Target.Value = "" Then Target.Offset(0, -2).Value = Target.Offset(0, -2).Value + cVal End If End If Application.EnableEvents = False 'clear fill from deleted entries For i = 2 To LastRow If Cells(i, "C").Value = "" Then Range("G" & i & ":" & "H" & i).ClearContents Range("G" & i & ":" & "H" & i).Interior.ColorIndex = xlNone End If If Cells(i, "G").Value = "" Then Range("G" & i & ":" & "H" & i).Interior.ColorIndex = xlNone End If Next i 'Evaluate First Response Time For i = 2 To LastRow If UCase(Cells(i, "C").Value) = "ALTA" And Cells(i, "G").Value <> "" And Cells(i, "G").Value <= Range("o2").Value Then Cells(i, "G").Interior.ColorIndex = 35 ElseIf UCase(Cells(i, "C").Value) = "ALTA" And Cells(i, "G").Value <> "" And Cells(i, "G").Value > Range("o2").Value Then Cells(i, "G").Interior.ColorIndex = 3 End If Next i For i = 2 To LastRow If UCase(Cells(i, "C").Value) = "MEDIA" And Cells(i, "G").Value <> "" And Cells(i, "G").Value <= Range("o3").Value Then Cells(i, "G").Interior.ColorIndex = 35 ElseIf UCase(Cells(i, "C").Value) = "MEDIA" And Cells(i, "G").Value <> "" And Cells(i, "G").Value > Range("o3").Value Then Cells(i, "G").Interior.ColorIndex = 3 End If Next i For i = 2 To LastRow If UCase(Cells(i, "C").Value) = "BAJA" And Cells(i, "G").Value <> "" And Cells(i, "G").Value <= Range("o4").Value Then Cells(i, "G").Interior.ColorIndex = 35 ElseIf UCase(Cells(i, "C").Value) = "BAJA" And Cells(i, "G").Value <> "" And Cells(i, "G").Value > Range("o4").Value Then Cells(i, "G").Interior.ColorIndex = 3 End If Next i 'Evaluate Elapsed Time For i = 2 To LastRow If UCase(Cells(i, "C").Value) = "ALTA" And Cells(i, "H").Value <> "" And Cells(i, "H").Value <= Range("P2").Value Then Cells(i, "H").Interior.ColorIndex = 35 ElseIf UCase(Cells(i, "C").Value) = "ALTA" And Cells(i, "H").Value <> "" And Cells(i, "H").Value > Range("P2").Value Then Cells(i, "H").Interior.ColorIndex = 3 End If Next i For i = 2 To LastRow If UCase(Cells(i, "C").Value) = "MEDIA" And Cells(i, "H").Value <> "" And Cells(i, "H").Value <= Range("P3").Value Then Cells(i, "H").Interior.ColorIndex = 35 ElseIf UCase(Cells(i, "C").Value) = "MEDIA" And Cells(i, "H").Value <> "" And Cells(i, "H").Value > Range("P3").Value Then Cells(i, "H").Interior.ColorIndex = 3 End If Next i For i = 2 To LastRow If UCase(Cells(i, "C").Value) = "BAJA" And Cells(i, "H").Value <> "" And Cells(i, "H").Value <= Range("P4").Value Then Cells(i, "H").Interior.ColorIndex = 35 ElseIf UCase(Cells(i, "C").Value) = "BAJA" And Cells(i, "H").Value <> "" And Cells(i, "H").Value > Range("P4").Value Then Cells(i, "H").Interior.ColorIndex = 3 End If Next i Application.EnableEvents = True End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 10 Then cVal = Target.Value End If End Sub
I have changed the code, and I have kept your methodology, but it is not good because you are not using events as they should be used, to respond to the target of the event and any related items. Instead, you are changing everything. To compound it, when the values in D, E, or F change, you are not updating the calculated times, that has to wait for the user to trigger it on the next double-click.
Your code should check C, and update that row alone. Similarly, it should check D and E, if either is changed and both have values, calculate the working time; it should check D & F, if either is changed and both have values then calculate the elapsed time.
Ayway, here is the code.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Const WORKING_DAY_START As String = "09:00" Const WORKING_DAY_END As String = "18:00" Const FORMULA_WORKING_TIME As String = _ "=(INT(E2-D2)*(""" & WORKING_DAY_END & """-""" & WORKING_DAY_START & """)" & _ "+MEDIAN(MOD(E2,1),""" & WORKING_DAY_END & """,""" & WORKING_DAY_START & """)" & _ "-MEDIAN(MOD(D2,1),""" & WORKING_DAY_END & """,""" & WORKING_DAY_START & """))" Const FORMULA_ELAPSED_TIME As String = "=F2-D2" Dim lastrow As Long On Error GoTo ws_bdc_exit Application.ScreenUpdating = False Application.EnableEvents = False With Me lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row 'input Elapsed Time .Range("H2").Resize(lastrow - 1).Formula = FORMULA_ELAPSED_TIME 'input First Response time .Range("G2").Resize(lastrow - 1).Formula = FORMULA_WORKING_TIME With .Range("G2:H2").Resize(lastrow - 1) .Value = .Value .NumberFormat = "[h]:mm_w" End With End With ws_bdc_exit: Target.Offset(1).Select Application.ScreenUpdating = True Application.EnableEvents = True End Sub
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
Thank you for replying!
it seems to be working BUT i was no able to obtain the "Extra time" :/. I tried to use my code but it fails
Last edited by xld; 04-26-2019 at 01:36 AM. Reason: Removed previous message quote
Sorry, I am not sure what you mean, my code does working time and elapsed time.
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Const WORKING_DAY_START As String = "09:00" Const WORKING_DAY_END As String = "18:00" Const FORMULA_WORKING_TIME As String = _ "=(INT(E2-D2)*(""" & WORKING_DAY_END & """-""" & WORKING_DAY_START & """)" & _ "+MEDIAN(MOD(E2,1),""" & WORKING_DAY_END & """,""" & WORKING_DAY_START & """)" & _ "-MEDIAN(MOD(D2,1),""" & WORKING_DAY_END & """,""" & WORKING_DAY_START & """))" Const FORMULA_ELAPSED_TIME As String = "=F2-D2" Dim lastrow As Long On Error GoTo ws_bdc_exit Application.ScreenUpdating = False Application.EnableEvents = False With Me lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row 'input Elapsed Time .Range("H2").Resize(lastrow - 1).Formula = FORMULA_ELAPSED_TIME 'input First Response time .Range("G2").Resize(lastrow - 1).Formula = FORMULA_WORKING_TIME With .Range("G2:H2").Resize(lastrow - 1) .Value = .Value .NumberFormat = ##0.00" End With End With ws_bdc_exit: Target.Offset(1).Select Application.ScreenUpdating = True Application.EnableEvents = True End Sub
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
That should read
.NumberFormat = "##0.00"
(extra quote).
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber