PDA

View Full Version : Work hours between 2 dates(not working -VBA)



007_guy
04-20-2019, 07:50 AM
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

Bob Phillips
04-21-2019, 09:03 AM
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

007_guy
04-21-2019, 10:41 AM
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


Thank you for replying!
I want to use a macro, i've tried to use something similar but it did not work :/

Could you please help me to modify it?:confused4:confused4:confused4

Bob Phillips
04-21-2019, 11:34 AM
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.

007_guy
04-21-2019, 12:13 PM
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.

Well, thats the problem :(.. i dont know how to modify it :/

007_guy
04-21-2019, 01:35 PM
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.
My macro in stored in the workbook document inside the excel file

Bob Phillips
04-22-2019, 02:25 AM
This code does it.


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

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.

007_guy
04-22-2019, 11:33 AM
This code does it.


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

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.



I've tried to merge that code in my macro but it did not work :(
Could you please help me to modify my macro? (this is inside the excel file)

Bob Phillips
04-22-2019, 12:35 PM
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.

007_guy
04-24-2019, 04:26 PM
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

Bob Phillips
04-25-2019, 04:09 AM
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.

007_guy
04-25-2019, 10:15 AM
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

Bob Phillips
04-25-2019, 10:43 AM
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

007_guy
04-25-2019, 12:22 PM
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 :(

Bob Phillips
04-26-2019, 01:37 AM
Sorry, I am not sure what you mean, my code does working time and elapsed time.

007_guy
04-26-2019, 07:03 AM
Sorry, I am not sure what you mean, my code does working time and elapsed time.

Your code is working, it shows the difference between the different dates BUT i want to display the input in hours (NOT hours + minutes).
How would you change it?

Bob Phillips
04-26-2019, 11:23 AM
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

007_guy
04-26-2019, 11:52 AM
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


It throws syntax error on this line: .NumberFormat = ##0.00" :(

Bob Phillips
04-26-2019, 12:56 PM
That should read

.NumberFormat = "##0.00"

(extra quote).

thepast
04-26-2019, 01:08 PM
It throws syntax error on this line: .NumberFormat = ##0.00" :(


.NumberFormat = "##0.00"

007_guy
04-26-2019, 01:28 PM
It seems to be working BUT it does not display the input in hours. It still shows the input with the format 0:00, do you get me?

007_guy
04-28-2019, 09:05 AM
That should read

.NumberFormat = "##0.00"

(extra quote).


Dude, your macro is working but now everything has changed. This is the full macro i am using:


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


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) = "High" 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) = "High" 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) = "Medium" 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) = "Medium" 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) = "Low" 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) = "Low" 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) = "High" 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) = "High" 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) = "Medium" 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) = "Medium" 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) = "Low" 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) = "Low" 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

If i use your Macro, everytime that i enter an "extra time" it will adjust The Elapsed Time value and it is correct but something is wrong because if i put an extra time and double click again on Date of the problem/Date First Response/Date Last Response it will put the original value on "The Elapsed Time" cell and thats not correct. It should not modify anything! (PS: i have to double click on "extra time" to modify the value stored in "The Elapsed Time" and in my previous Macro it was not necessary)


Also, if First response and Elapsed time have a value >, < or equal to the other values (depending on the priority) it will have a different colour but with your Macro it has stopped working properly. Why?

Could you please help me to solve this mess?

Take a look at this imag:

https://imgur.com/a/RqIYOA4

007_guy
04-28-2019, 09:33 AM
That should read

.NumberFormat = "##0.00"

(extra quote).


Dude, i think there was a misunderstanding..
First response is calculated by the difference between: Date First Response and Date of the problem
Elapsed time is calculated by the difference between: Date Last Response and Date of the problem

THAT's the problem in your Macro