Forum Discussion

NikolinoDE's avatar
NikolinoDE
Gold Contributor
Jul 08, 2020

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?

 TEST Sheet 

 

Ps. My knowledge in Excel is not the best, but my knowledge in VBA is almost non-existent 😞
 

Any help is welcome

Thx in Advance

Nikolino

  • NikolinoDE 

    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!

  • NikolinoDE 

    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?

Resources