Hi Frank!

My final version is below.

I had trouble with the DateFormat constant. Also the TestRange
constant appears "sticky" so there might be change to that one.

I put back the format if the cell is already a date

I found a more acceptable response to amending a date which is to
amend the EndMacro error treatment: clear the bugger and format as
text. OK I still get the error message when I really shouldn't but it
doesn't then leave me with the date represented by the date serial
number of the entry.

Still a bit of testing to do, but I think it works OK. I'll post to
Chip. On his site, in the lead in he says, "If you use European style
dates (ddmmyyyy), you'll have to change some of the code." I'm going
to report him to the NSPCA!

I suppose that to be a bit more bullet proof it needs code that checks
the date settings and then runs the US or European code accordingly.
But I think I'll put that in the very large "to do" file.



Const TestRange As String = "A1:A10"

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'Object here is to format as text as soon as selection is made.
'I'll change to a date format when I've parsed the entry.
'This avoids leading zero and other inadmissible date probs.

'Usual exit if not in my range
If Application.Intersect(Target, Range(TestRange)) Is Nothing Then
Exit Sub
End If

'More than 1 cell selected is a no no.
If Target.Cells.Count 1 Then
Exit Sub
End If

'If I already have a date then just format
If IsDate(Target.Value) Then
Target.NumberFormat = "dd-mmm-yyyy"
Exit Sub
End If

'Format as text to prevent dropping leading 0
Target.NumberFormat = "@"

End Sub


Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'This is the European date entry / format version
'Credits: CP,NH,BP,FK,VB

Dim DateStr As String

On Error GoTo EndMacro

'Usual exit if not in my range
If Application.Intersect(Target, Range(TestRange)) Is Nothing Then
Exit Sub
End If

'More than 1 cell selected is a no no.
If Target.Cells.Count 1 Then
Exit Sub
End If

'Should this be changed or omitted?
If Target.Formula = "" Then
Exit Sub
End If

'Can't have my buggering about triggering an event
Application.EnableEvents = False

'Parse the text entry
If Target.HasFormula = False Then
Select Case Len(Target)

Case 4 ' e.g., 9298 = 9-Feb-1998
'I could trap annoying second digit 0 problem
DateStr = Left(Target, 1) & "/" & _
Mid(Target, 2, 1) & "/" & Right(Target, 2)

Case 5 ' e.g., 11298 = 11-Feb-1998 NOT 1-Dec-1998
'I could trap annoying first or third digit 0 problem
DateStr = Left(Target, 2) & "/" & _
Mid(Target, 3, 1) & "/" & Right(Target, 2)

Case 6 ' e.g., 090298 = 9-Feb-1998
DateStr = Left(Target, 2) & "/" & _
Mid(Target, 3, 2) & "/" & Right(Target, 2)

Case 7 ' e.g., 1121998 = 11-Feb-1998 NOT 1-Dec-1998
DateStr = Left(Target, 2) & "/" & _
Mid(Target, 3, 1) & "/" & Right(Target, 4)

Case 8 ' e.g., 11121998 = 11-Dec-1998
DateStr = Left(Target, 2) & "/" & _
Mid(Target, 3, 2) & "/" & Right(Target, 4)

Case Else
Err.Raise 0
End Select

'Now format the cell for a date
Target.NumberFormat = "dd-mmm-yyyy"

With Target
'In goes the parsed date
.Value = Format(DateValue(DateStr), "dd-mmm-yyyy")
End With

End If
Application.EnableEvents = True
Exit Sub

EndMacro:
MsgBox "You did not enter a valid date."
Target.Clear
Target.NumberFormat = "@"
Application.EnableEvents = True

End Sub 'Worksheet_Change


--
Regards
Norman Harker MVP (Excel)
Sydney, Australia

Excel and Word Function Lists (Classifications, Syntax and Arguments)
available free to good homes.