Create a subroutine to determine what shift is currently working based off the current time

[cchristner]

Hey guys,

Is there a way to create a subroutine to determine what shift is working based on the time. So Third shift starts at 10:00 pm, First shift starts at 6:00 am and second starts at 2:00 pm. I want to be able to create a button that when its push will put the current shift in cell (G1). Any help would be greatly appreciated

 

[bobsan42]

try this:

Option Explicit

Private Sub PressTheButton()
    Dim rng As Range
    Dim ttt, t1, ts
    t1 = TimeValue("06:00:00")
    ts = TimeValue("08:00:00")
    ttt = Time - t1
    Debug.Print CDate(ttt + t1)
    Set rng = ActiveSheet.Range("G1")
    With rng
        Select Case ttt
            Case Is < 0, Is > 2 * ts
                .Value = "Third shift"
            Case Is < ts
                .Value = "First shift"
            Case Is > 2 * ts
                .Value = "Third shift"
            Case Else
                .Value = "Second shift"
        End Select
    End With
End Sub

 

[cchristner]

So would I call that routine than? I am creating a log book and I want it to automatically add the shift when save is clicked. Here is a copy of my current save routine where would I have to add the code to make it call that code?

|Sub SaveITO()
Dim Path As String
Dim FileName1 As String
Dim DateTime As String
Dim PathAndFileName As String
Path = "\\znas1\Production\OEC\GlassCoating\Coater 1\Citect\LogBook\ITO Log books"
If Range("C1").Value = "" Then
MsgBox "You Must Put a Value in Cell C1!"


Exit Sub
End If
FileName1 = Range("C1")
DateTime = " (" & Format(Now, "yyyy-mm-dd hhmm AMPM") & ").xlsm"
PathAndFileName = Path & FileName1 & "-" & DateTime & ".xlsm"
ActiveWorkbook.SaveCopyAs Filename:=PathAndFileName
SetAttr PathAndFileName, vbReadOnly
End Sub|

 

[bobsan42]

generally - wherever you like after the C1 check and before the SaveAs:

Option Explicit

Private Sub PressTheButton()
    Dim rng As Range
    Dim ttt, t1, ts
    t1 = TimeValue("06:00:00")
    ts = TimeValue("08:00:00")
    ttt = Time - t1
    Debug.Print CDate(ttt + t1)
    Set rng = ActiveSheet.Range("G1")
    With rng
        Select Case ttt
            Case Is < 0, Is > 2 * ts
                .Value = "Third shift"
            Case Is < ts
                .Value = "First shift"
            Case Is > 2 * ts
                .Value = "Third shift"
            Case Else
                .Value = "Second shift"
        End Select
    End With
End Sub

Sub SaveITO()
    Dim Path As String
    Dim FileName1 As String
    Dim DateTime As String
    Dim PathAndFileName As String
        Path = "\\znas1\Production\OEC\GlassCoating\Coater 1\Citect\LogBook\ITO Log books"
        If Range("C1").Value = "" Then
            MsgBox "You Must Put a Value in Cell C1!"
            Exit Sub
        End If
        FileName1 = Range("C1")
        DateTime = " (" & Format(Now, "yyyy-mm-dd hhmm AMPM") & ").xlsm"
        PathAndFileName = Path & FileName1 & "-" & DateTime & ".xlsm"
[COLOR=#ff0000]        Call PressTheButton[/COLOR]
    ActiveWorkbook.SaveCopyAs Filename:=PathAndFileName
    SetAttr PathAndFileName, vbReadOnly
End Sub

 

[cchristner]

Thank you that was very helpful.