Forum Discussion
entering the working time, automatically marked with color in the timeline.
When entering the working time in a time entry, this time should be automatically marked with color in the timeline.
Is this possible?
if yes... how?
Any help is welcome
Thx in Advance
Nikolino
No problem. Here is the code you need to place on Next month's Sheet module.
Public sTimeFound As Boolean Public sColumn As Long Public eColumn As Long Private Sub Worksheet_Change(ByVal Target As Range) If Target.CountLarge > 1 Then Exit Sub Dim timeType As String Dim dt As Date Dim empRow As Long Dim startCell As Range Dim timeRng As Range Dim dtCel As Range Dim tCel As Range Dim dtRng As Range Dim emp As String Dim n As Variant Dim dws As Worksheet Dim empRng As Range Dim inputRng As Range Dim clr As Long Set dws = Worksheets("IND1") Set empRng = dws.Range("H1:Q1") Set dtRng = dws.Range("C8:C348") Set timeRng = dws.Range("F8:BA8") Set inputRng = Range("I10:EZ40") Application.EnableEvents = False If Not Intersect(Target, inputRng) Is Nothing Then timeType = VBA.Trim(Cells(9, Target.Column).Value) emp = Cells(5, Target.Column).MergeArea.Cells(1).Value n = Application.Match(emp, empRng, 0) clr = empRng.Cells(n).Interior.Color If IsError(n) Then MsgBox "The employee " & emp & " doesn't exist on " & dws.Name & " Sheet.", vbExclamation GoTo Skip End If If (LCase(timeType) = "from" Or LCase(timeType) = "to") And Target <> "" Then dt = Cells(Target.Row, 2).Value For Each dtCel In dtRng If dtCel.Value = dt Then empRow = dtCel.Row empRow = empRow + n Exit For End If Next dtCel For Each tCel In timeRng If CDate(tCel.Value) = CDate(Target.Value) And LCase(timeType) = "from" Then sColumn = tCel.Column With dws.Cells(empRow, sColumn) .Value = Target.Value .NumberFormat = "hh:mm" End With sTimeFound = True Exit For ElseIf CDate(tCel.Value) = CDate(Target.Value) And LCase(timeType) = "to" Then eColumn = tCel.Column With dws.Cells(empRow, eColumn) .Value = Target.Value .NumberFormat = "hh:mm" End With End If Next tCel End If If sColumn <> 0 And eColumn <> 0 And sTimeFound = True Then If Application.Count(dws.Range("F" & empRow, dws.Cells(empRow, sColumn - 1))) = 0 Then dws.Range("F" & empRow, dws.Cells(empRow, sColumn - 1)).Interior.ColorIndex = xlNone ElseIf Application.Count(dws.Range(dws.Cells(empRow, eColumn + 1), "BA" & empRow)) = 0 Then dws.Range(dws.Cells(empRow, eColumn + 1), "BA" & empRow).Interior.ColorIndex = xlNone End If dws.Range(dws.Cells(empRow, sColumn), dws.Cells(empRow, eColumn)).Interior.Color = clr sColumn = 0 eColumn = 0 sTimeFound = False End If End If Skip: Application.EnableEvents = True End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Unprotect "1234" With Range("A10:EZ40").Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .PatternTintAndShade = 1 End With If Not Intersect(Target, Range("A10:EZ40")) Is Nothing Then With Range(Cells(Target.Row, 1), Cells(Target.Row, 156)).Interior .Pattern = xlGray25 .PatternThemeColor = xlThemeColorAccent2 .PatternTintAndShade = 0.399945066682943 End With Application.EnableEvents = False Target.Activate Application.EnableEvents = True End If Protect "1234" End Sub
Also, don't forget to mark the post with the proposed solution as a Best Response. 🙂
Thanks for all your wishes.
Have a good time ahead!
- Subodh_Tiwari_sktneerSilver Contributor
Your table is blank so it is hard to visualize what exactly you are trying to achieve here.
Why not enter some time values and mock up the desired output manually and upload the file again to show what you are trying to achieve?
- NikolinoDEGold ContributorHi Subodh_Tiwari_sktneer,
sorry for my mistake, wrong file 😞
here is the right file 🙂
https://www.transfernow.net/mK46HT072020
Please download the file and my project is then self-explanatory 🙂
Thx in Advance for any help.
Nikolino- Subodh_Tiwari_sktneerSilver Contributor
I have placed the formulas in rows 7 and 8 and you will need to copy the same formula to other rows but change the range reference accordingly. Remember these are Array Formulas so you will need to confirm it with Ctrl+Shift+Enter not Enter only.