Macro button

Phil Cox 

Please find the attached with the code on Module1. I replaced the ActiveX Commandbuttons you inserted on Input Sheet with the Rectangular Shapes and renamed them properly to make it work correctly. Please don't mess with the names and captions of these buttons. The code on Module1 is assigned to all of these buttons.

Code on Module1:

Sub FillData()
Dim wsInput     As Worksheet
Dim wsData      As Worksheet
Dim shp         As Shape
Dim TimeCol     As Variant
Dim x           As Long
Dim r           As Variant
Dim EType       As String
Dim Region      As String

If Time > TimeSerial(18, 30, 0) And Time < TimeSerial(5, 30, 0) Then
    MsgBox "Out of scheduled time!", vbExclamation
    Exit Sub
End If
Set wsInput = ThisWorkbook.Worksheets("Input Sheet")
Set wsData = ThisWorkbook.Worksheets("Data Sheet")

Set shp = wsInput.Shapes(Application.Caller)

EType = shp.OLEFormat.Object.Caption
Region = Split(shp.Name, "_")(1)

If EType = "Emp" Then
    x = 0
ElseIf EType = "Vet" Then
    x = 1
End If

On Error Resume Next
TimeCol = Application.Match(CDbl(Time), wsData.Rows(3))
r = Application.Match(Region, wsData.Columns(1), 0)
On Error GoTo 0

If IsError(TimeCol) Then
    MsgBox "No time slot was found on Data Sheet!", vbExclamation
    Exit Sub
End If

If IsError(r) Then
    MsgBox "No header for """ & Region & """ was found in column A of " & wsData.Name & "!", vbExclamation
    Exit Sub
End If

With wsData.Cells(r, TimeCol + x)
    .Value = 1
    .Interior.Color = vbYellow
End With
Application.Goto wsData.Cells(r, TimeCol + x)
End Sub