I use a small macro to do this
Try pasting the follwoing into the worksheet coe area. To do that right click on the X icon at the top left of the required worksheet and paste the following code.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim TimeStr As String
Dim InputRange As Range
Dim cellValue As String
Dim SecondsInDay As Long
Dim SecondsSince1200 As Long
Dim Hours As Long
Dim Minutes As Long
Dim SecondsInHour As Long
Dim bValid As Boolean
Dim Test As Variant
'Set InputRange = Union( _
Range("g44:g47,d44:d47,j44:j47,M44:M47"), _
Range("f45:f47,i45:i47,l45:l47,O45:O47"), _
Range("F9:F11,G8:G11,I9:I11,L9:L11"), _
Range("G17:G20,I18:I20,G26:G29,I27:I29,G35:G38,I36:I38,J35:J38,J26:J29,J17:J20"), _
Range("J8:J11,O9:O11,M8:M11,M17:M20,O18:O20,M26:M29,O27:O29,M35:M38,O36:O38,D8:D11"), _
Range("D17:D20,D26:D29,D35:D38,F36:F38,F27:F29,F18:F20"), _
Range("F9:F11,I9:I11,L9:L11,O9:O11,F18:F20,I18:I20"), _
Range("L18:L20,O18:O20,F27:F29,I27:I29,L27:L29,O27:O29"), _
Range("F36:F38,I36:I38,L36:L38,O36:O38,F45:F47,I45:I47,L45:L48,L45:L47,O45:O47"))
SecondsInHour = 3600
SecondsInDay = 86400 '(24 * 3600)
On Error GoTo EndMacro
'If Application.Intersect(Target, InputRange) Is Nothing Then
' Exit Sub
'End If
If Target.Cells.Count > 1 And ActiveSheet.[D8].Value <> 0 Then
Target.Cells(1, 1).Select
Target.Cells(1, 1).Activate
MsgBox "Error - You cannot select more than one cell for entry." & vbCrLf & "Please select only one cell and re-enter a time between 0(0:00) and 2359(23:59)", _
vbOKOnly, "Too many cells selected"
Target.Cells(1, 1).Value = ""
Exit Sub
End If
If Target.Cells(1, 1) Is Nothing Or _
IsEmpty(Target.Cells(1, 1).Value) Or _
Target.Cells.Count > 1 Then
Exit Sub
End If
Application.ScreenUpdating = False
ActiveSheet.Unprotect
bValid = False
With Target
If IsNumeric(.Value) Then
If .Value < 1 Then ' we probably have a real time
' convert to a time string
SecondsSince1200 = SecondsInDay * .Value
Hours = Int(SecondsSince1200 / SecondsInHour)
Minutes = Int((SecondsSince1200 - (Hours * SecondsInHour)) / CLng(60))
TimeStr = Hours & ":" & Minutes
' time was entered as a time
bValid = True
End If
End If
' process as a string
If .HasFormula = False And Not bValid Then
cellValue = Trim(TrimNonNumerics(Target.Value)) ' clean up value if string
If Len(cellValue) = 0 Then
MsgBox "This entry cannot be interpreted as a time", vbOKOnly, _
"Incorrect time entry"
End If
' format time based on number length
Select Case Len(cellValue)
Case 1 ' e.g., 1 = 00:01 AM
TimeStr = "00:0" & cellValue
Case 2 ' e.g., 12 = 00:12 AM
TimeStr = "00:" & cellValue
Case 3 ' e.g., 735 = 7:35 AM
TimeStr = Left(cellValue, 1) & ":" & Right(cellValue, 2)
Case 4 ' e.g., 1234 = 12:34
TimeStr = Left(cellValue, 2) & ":" & Right(cellValue, 2)
Case 5 ' e.g., 12345 = 1:23:45 NOT 12:03:45
TimeStr = Left(cellValue, 1) & ":" & Mid(cellValue, 2, 2) _
& ":" & Right(cellValue, 2)
Case 6 ' e.g., 123456 = 12:34:56
TimeStr = Left(cellValue, 2) & ":" & Mid(cellValue, 3, 2) _
& ":" & Right(cellValue, 2)
Case Else
MsgBox "The time entered " & cellValue & " cannot be recognised." & vbCrLf & _
"Please re-enter", vbOKOnly & vbInformation, "Invalid Time Entered"
.Value = ""
Exit Sub
End Select
End If
' this will create an error is the time sting is > 23:59
Test = TimeValue(TimeStr) ' need to do thai as the enable events will disable error trap
Application.EnableEvents = False ' the change causes yet another change event
.Value = TimeValue(TimeStr)
Application.EnableEvents = True
' value is 0 to 2400
End With
Application.ScreenUpdating = True
Exit Sub
EndMacro:
Application.ScreenUpdating = True
Target.Cells(1, 1).Select ' an error is generated if more than one cell is updated
If Target.Cells(1, 1).Value > "" Then ' we have an invalid string most likely
MsgBox "Error - You did not enter a valid time: " & Target.Value & vbCrLf _
& "Please re-enter a time between 0(0:00) and 2359(23:59)", vbOKOnly, _
"Incorrect time entry"
End If
Application.EnableEvents = False
Target.Value = "" ' set value to blank
Application.EnableEvents = True
End Sub
Function TrimNonNumerics(StIn As Variant) As Variant
Dim I As Integer
I = Len(StIn)
If Not IsNumeric(StIn) Then
While I > 0
Select Case Mid(StIn, I, 1)
Case "0" To "9"
Case ":" ' Time strings
Case Else
'remove a character
If I = 1 Then
StIn = Right(StIn, Len(StIn) - I)
Else
StIn = Left(StIn, I - 1) & Right(StIn, Len(StIn) - I)
End If
End Select
I = I - 1
Wend
End If
TrimNonNumerics = StIn
End Function
