Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo UpS
If Target.Count > 1 Then Exit Sub
Dim stxt, lnt, tInt(4), npR, tVal(2)
stxt = Target.Text: lnt = Len(stxt): npR = 0
If lnt < 3 Or lnt > 9 Then Exit Sub
If lnt > 4 Then
For k = 1 To lnt
If Mid(stxt, k, 1) = "-" Then npR = k: Exit For
Next k
End If
If npR > 0 Then
tVal(1) = Mid(stxt, 1, npR - 1)
tVal(2) = Mid(stxt, npR + 1, lnt - npR)
Else
tVal(1) = stxt
tVal(2) = ""
End If
If Len(tVal(1)) = 3 Then
tInt(1) = Mid(tVal(1), 1, 1)
tInt(2) = Mid(tVal(1), 2, 2)
Else
tInt(1) = Mid(tVal(1), 1, 2)
tInt(2) = Mid(tVal(1), 3, 2)
End If
stxt = ""
If npR > 0 Then
If Len(tVal(2)) = 3 Then
tInt(3) = Mid(tVal(2), 1, 1)
tInt(4) = Mid(tVal(2), 2, 2)
Else
tInt(3) = Mid(tVal(2), 1, 2)
tInt(4) = Mid(tVal(2), 3, 2)
End If
stxt = "-" & tInt(3) & ":" & tInt(4)
End If
stxt = tInt(1) & ":" & tInt(2) & stxt
If Val(tInt(1)) > 24 Or Val(tInt(3)) > 24 Or Val(tInt(2)) > 59 Or Val(tInt(4)) > 59 Then GoTo UpS
Application.EnableEvents = False
Target.Value = stxt
Application.EnableEvents = True
Exit Sub
UpS:
Err.Clear
Resume Next
End Sub