Quick Date Entry European

[Frank Kabel]

Hi Norman
so though this is not a 100% solution it is nearly o.k
Would you email/send this to chip to include this on his site (for
further references) ?

 

[Norman Harker]

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
(e-mail address removed)
Excel and Word Function Lists (Classifications, Syntax and Arguments)
available free to good homes.

 

[Frank Kabel]

Hi Norman

like your solution but I wasn't satisfied with the small drawbacks
(re-entry of 6 digits or leading zeros). So I Changed the
selection_Change event as posted below:
- included a static variable for the previous selection
- ALWAYS change the format of the selected cell to 'Text'
- BUT restore the date format again after the selection has left the
filled cell.

One drawback: The user sees the conversion to a serial date number if
he selects a filled date cell. No idea how to prevent this.
Waiting for your' (and Bob's) comments <vbg>

------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'use a static variable to store the old selection.
'Used to restore the date format after a the selected cell with a
'value has been changed to text format
Static OldSelection As Range

'Restore the date format for filled cells. Disable events to prevent
'triggering the worksheet_change event
If Not OldSelection Is Nothing Then
With OldSelection
If .Value <> "" Then
Application.EnableEvents = False
.NumberFormat = "dd-mmm-yyyy"
.Value = .Value
Application.EnableEvents = True
End If
End With
End If

'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

'Frank Kabel: Disabled as no longer needed
'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 = "@"

'set the static variable
Set OldSelection = Target
End Sub

 

[Norman Harker]

Hi Frank!

I think we're getting there!

I much prefer the new approach to variations and I'm sure we can live
with seeing the date serial number if we select an entered cell.

It seems to be OK on my testing data set.

--
Regards
Norman Harker MVP (Excel)
Sydney, Australia
(e-mail address removed)
Excel and Word Function Lists (Classifications, Syntax and Arguments)
available free to good homes.

 

[Frank Kabel]

Hi Norman
to prevent seeing the serial number in the cell one may apply a white
font color within the Selection_change event. E.g. use the following
additions to the code:

[....]
If Not OldSelection Is Nothing Then
With OldSelection
If .Value <> "" Then
Application.EnableEvents = False
.NumberFormat = "dd-mmm-yyyy"
.Value = .Value
.Font.ColorIndex = xlColorIndexAutomatic
Application.EnableEvents = True
End If
End With
End If

[....]
Target.NumberFormat = "@"
If Target.Value <> "" Then
Target.Font.ColorIndex = 2
End If

---
but this is more a little bit playing around after midnight
Drawback: If you re-enter something you won't see your entry in the
cell until you left the cell

 

[Frank Kabel]

Norman
and another addition: In my tests I encounter the problem that after
re-entring invalid dates the format stays as 'Text' even for valid
dates in this cell. So I changed the line

..Value = Format(DateValue(DateStr), "dd-mmm-yyyy")

to
..Value = DateValue(DateStr)

No need for the formating as you have set the number format prior to
this line

---- Full Code (with white font color)


Const TestRange As String = "A1:A10"

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'use a static variable to store the old selection.
'Used to restore the date format after a the selected cell with a
'value has been changed to text format
Static OldSelection As Range

'Restore the date format for filled cells. Disable events to prevent
'triggering the worksheet_change event
If Not OldSelection Is Nothing Then
With OldSelection
If .Value <> "" Then
Application.EnableEvents = False
.NumberFormat = "dd-mmm-yyyy"
.Value = .Value
.Font.ColorIndex = xlColorIndexAutomatic
Application.EnableEvents = True
End If
End With
End If

'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

'Format as text to prevent dropping leading 0
Target.NumberFormat = "@"
If Target.Value <> "" Then
Target.Font.ColorIndex = 2
End If

'set the static variable
Set OldSelection = Target
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 = DateValue(DateStr)
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
Frank Kabel
Frankfurt, Germany

Hi Norman
to prevent seeing the serial number in the cell one may apply a white
font color within the Selection_change event. E.g. use the following
additions to the code:

[....]
If Not OldSelection Is Nothing Then
With OldSelection
If .Value <> "" Then
Application.EnableEvents = False
.NumberFormat = "dd-mmm-yyyy"
.Value = .Value
.Font.ColorIndex = xlColorIndexAutomatic
Application.EnableEvents = True
End If
End With
End If

[....]
Target.NumberFormat = "@"
If Target.Value <> "" Then
Target.Font.ColorIndex = 2
End If

---
but this is more a little bit playing around after midnight
Drawback: If you re-enter something you won't see your entry in the
cell until you left the cell

Hi Frank!

I think we're getting there!

I much prefer the new approach to variations and I'm sure we can live
with seeing the date serial number if we select an entered cell.

It seems to be OK on my testing data set.

 

[Norman Harker]

Hi Frank!

If you're used to editing in cell, it can be distracting but I suppose
on balance I prefer it and you'd soon get used to it.

For "true" European format I suppose yyyy-mm-dd should be used but
then you wouldn't expect an ex-Pom to be a true European <vbg>

I tend to use a non-white base colour as it's more restful on
bloodshot eyes.

I think Bob wants to stay married and has gone to bed!
--
Regards
Norman Harker MVP (Excel)
Sydney, Australia
(e-mail address removed)
Excel and Word Function Lists (Classifications, Syntax and Arguments)
available free to good homes.