Quick Date entry revisited

[Frank Kabel]

Hi to all
following the thread from the last days I created a version which would
work for both US-Style and European Style. the only thing to do is
change the Compiler constand #Const US_STYLE

Short summary of changes:
- To allow US entry for Europeans and vice versa I had to change the
usage of DateValue to DateSerial as DateValue uses the regional
settings.
- Included compiler directives
- made the dateformat string a constant
- included the original parsing from Chip's site

Testing on my machine was O.K. but feel free to comment 8this goes
especially to Bob and Norman)

---------

Option Explicit
'Change these constants according to your requirements
#Const US_STYLE = False
Const TestRange As String = "A1:A10"

#If US_STYLE Then
Const DateFormat = "MMM-DD-YYYY"
#Else
Const DateFormat = "DD-MMM-YYYY"
#End If

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 = DateFormat
.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 and US date entry / format version
'Credits: CP,NH,BP,FK,VB

Dim Val_date As Date

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
#If US_STYLE Then
Select Case Len(Target)
Case 4 ' e.g., 9298 = 2-Sep-1998
Val_date = DateSerial(Right(Target, 2), Left(Target,
1), _
Mid(Target, 2, 1))
Case 5 ' e.g., 11298 = 12-Jan-1998 NOT 2-Nov-1998
Val_date = DateSerial(Right(Target, 2), Left(Target,
1), _
Mid(Target, 2, 2))
Case 6 ' e.g., 090298 = 2-Sep-1998
Val_date = DateSerial(Right(Target, 2), Left(Target,
2), _
Mid(Target, 3, 2))
Case 7 ' e.g., 1231998 = 23-Jan-1998 NOT 3-Dec-1998
Val_date = DateSerial(Right(Target, 4), Left(Target,
1), _
Mid(Target, 2, 2))
Case 8 ' e.g., 09021998 = 2-Sep-1998
Val_date = DateSerial(Right(Target, 4), Left(Target,
2), _
Mid(Target, 3, 2))
Case Else
Err.Raise 0
End Select
#Else 'European style
Select Case Len(Target)
Case 4 ' e.g., 9298 = 9-Feb-1998
Val_date = DateSerial(Right(Target, 2), Mid(Target, 2,
1), _
Left(Target, 1))
Case 5 ' e.g., 11298 = 11-Feb-1998 NOT 1-Dec-1998
Val_date = DateSerial(Right(Target, 2), Mid(Target, 3,
1), _
Left(Target, 2))
Case 6 ' e.g., 090298 = 9-Feb-1998
Val_date = DateSerial(Right(Target, 2), Mid(Target, 3,
2), _
Left(Target, 2))
Case 7 ' e.g., 1121998 = 11-Feb-1998 NOT 1-Dec-1998
Val_date = DateSerial(Right(Target, 4), Mid(Target, 3,
1), _
Left(Target, 2))
Case 8 ' e.g., 11121998 = 11-Dec-1998
Val_date = DateSerial(Right(Target, 4), Mid(Target, 3,
2), _
Left(Target, 2))
Case Else
Err.Raise 0
End Select
#End If

'Now format the cell for a date
Target.NumberFormat = DateFormat

With Target
'In goes the parsed date
.Value = Val_date
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

 

[Norman Harker]

Hi Frank!

Good one!

Just a thought. Is it possible to determine the style required
without requiring the user to do it?

--
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 Frank!

Good one!

Just a thought. Is it possible to determine the style required
without requiring the user to do it?

Hi Norman
thought about that myself but didn't find anything to query the
regional settings. But maybe someone will step in to provide some code
to get the regional settings style for dates

Frank

 

[Bob Phillips]

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Bob Phillips]

Gentlemen, I have mailed offline to you both just half-an-hour ago.

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Tom Ogilvy]

From Application.International

xlDateOrder Long Order of date elements:
0 = month-day-year
1 = day-month-year
2 = year-month-day

Is that what you are looking for?

 

[Frank Kabel]

Tom
yes it is

 

[Ron de Bruin]

Hi Frank

Great stuff
I hope Chip will add it to his page.

If not I will add it to my webpage if you want