Quick Date entry revisited

From: Frank Kabel (frank.kabel_at_freenet.de)
Date: 04/10/04 

Date: Sat, 10 Apr 2004 15:15:16 +0200

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 

--
Regards
Frank Kabel
Frankfurt, Germany