An alternative is to test Target.Formula as Frank says, and just set the
numberformat if all ism okay to process. The problem with 6 digits was there
before Frank suggested Target.Formula, and is addressed by changing the
numberformat. I have added FormulaLocal as inpuuting 020998 reveresed the
date to 9/2/1998.
This version also gets over the initial input where nothing gets selected.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim DateStr As String
On Error GoTo EndMacro
If Application.Intersect(Target, Range( "A1:A10")) Is Nothing Then
Exit Sub
End If
If Target.Cells.Count 1 Then
Exit Sub
End If
If Target.Formula= "" Then
Exit Sub
End If
Target.NumberFormat = "@"
Application.EnableEvents = False
With Target
If .HasFormula = False Then
Select Case Len(.Formula)
Case 4 ' e.g., 9298 = 9-Feb-1998
DateStr = Left(.Formula, 1) & "/" & _
Mid(.Formula, 2, 1) & "/" & Right(.Formula, 2)
Case 5 ' e.g., 11298 = 11-Feb-1998 NOT 1-Dec-1998
DateStr = Left(.Formula, 2) & "/" & _
Mid(.Formula, 3, 1) & "/" & Right(.Formula, 2)
Case 6 ' e.g., 090298 = 9-Feb-1998
DateStr = Left(.Formula, 2) & "/" & _
Mid(.Formula, 3, 2) & "/" & Right(.Formula, 2)
Case 7 ' e.g., 1121998 = 11-Feb-1998 NOT 1-Dec-1998
DateStr = Left(.Formula, 2) & "/" & _
Mid(.Formula, 3, 1) & "/" & Right(.Formula, 4)
Case 8 ' e.g., 11121998 = 11-Dec-1998
DateStr = Left(.Formula, 2) & "/" & _
Mid(.Formula, 3, 2) & "/" & Right(.Formula, 4)
Case Else
Err.Raise 0
End Select
.FormulaLocal = DateValue(DateStr)
End If
End With
Application.EnableEvents = True
Exit Sub
EndMacro:
MsgBox "You did not enter a valid date."
Application.EnableEvents = True
End Sub
Dates are a pain, and the MS implementation has a high aroma.
--
HTH
Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)
"Bob Phillips" wrote in message
...
Norman,
Try this, it traps the selection event to set the cell format before
input,
and also uses formulalocal
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim DateStr As String
On Error GoTo EndMacro
If Application.Intersect(Target, Range("A1:A10")) Is Nothing Then
Exit Sub
End If
If Target.Cells.Count 1 Then
Exit Sub
End If
If Target.Value = "" Then
Exit Sub
End If
Application.EnableEvents = False
With Target
If .HasFormula = False Then
Select Case Len(.Formula)
Case 4 ' e.g., 9298 = 9-Feb-1998
DateStr = Left(.Formula, 1) & "/" & _
Mid(.Formula, 2, 1) & "/" & Right(.Formula, 2)
Case 5 ' e.g., 11298 = 11-Feb-1998 NOT 1-Dec-1998
DateStr = Left(.Formula, 2) & "/" & _
Mid(.Formula, 3, 1) & "/" & Right(.Formula, 2)
Case 6 ' e.g., 090298 = 9-Feb-1998
DateStr = Left(.Formula, 2) & "/" & _
Mid(.Formula, 3, 2) & "/" & Right(.Formula, 2)
Case 7 ' e.g., 1121998 = 11-Feb-1998 NOT 1-Dec-1998
DateStr = Left(.Formula, 2) & "/" & _
Mid(.Formula, 3, 1) & "/" & Right(.Formula, 4)
Case 8 ' e.g., 11121998 = 11-Dec-1998
DateStr = Left(.Formula, 2) & "/" & _
Mid(.Formula, 3, 2) & "/" & Right(.Formula, 4)
Case Else
Err.Raise 0
End Select
.FormulaLocal = DateValue(DateStr)
End If
End With
Application.EnableEvents = True
Exit Sub
EndMacro:
MsgBox "You did not enter a valid date."
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.Intersect(Target, Range("A1:A10")) Is Nothing Then
Exit Sub
End If
If Target.Cells.Count 1 Then
Exit Sub
End If
Target.NumberFormat = "@"
End Sub
--
HTH
Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)
"Norman Harker" wrote in message
...
Hi Frank!
I spoke too soon!
Case 6 now stuffs up
090298
--
Regards
Norman Harker MVP (Excel)
Sydney, Australia
Excel and Word Function Lists (Classifications, Syntax and Arguments)
available free to good homes.
"Frank Kabel" wrote in message
...
Hi
try changing the lines
If Target.Value= "" Then
Exit Sub
End If
to
If Target.Formula = "" Then
Exit Sub
End If
--
Regards
Frank Kabel
Frankfurt, Germany
"Frank Kabel" schrieb im Newsbeitrag
...
Hi Norman
this works for me if the cells are formated as 'General' or another
number format. If the cells are preformated as date I got an error
in
the line
If Target.Value = "" Then
Seems that i this case you get an overflow as '11111998' for
example
is
to large for a date value. so the procedure errors out and you get
the
'invalid date' message.
Format the cell as General and try again and everything works fine.
Not sure right now how to prevent this error just as a shor summary
of
my findings
--
Regards
Frank Kabel
Frankfurt, Germany
"Norman Harker" schrieb im Newsbeitrag
...
Hi All!
I'm amending Chip Pearson's quick date entry subroutine for the
non-US
date entry.
What's wrong with Case 8?
I've amended 4,5,6 and 7 but can't seem to get it to accept Case
8.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim DateStr As String
On Error GoTo EndMacro
If Application.Intersect(Target, Range("A1:A10")) Is Nothing Then
Exit Sub
End If
If Target.Cells.Count 1 Then
Exit Sub
End If
If Target.Value = "" Then
Exit Sub
End If
Application.EnableEvents = False
With Target
If .HasFormula = False Then
Select Case Len(.Formula)
Case 4 ' e.g., 9298 = 9-Feb-1998
DateStr = Left(.Formula, 1) & "/" & _
Mid(.Formula, 2, 1) & "/" & Right(.Formula, 2)
Case 5 ' e.g., 11298 = 11-Feb-1998 NOT 1-Dec-1998
DateStr = Left(.Formula, 2) & "/" & _
Mid(.Formula, 3, 1) & "/" & Right(.Formula, 2)
Case 6 ' e.g., 090298 = 9-Feb-1998
DateStr = Left(.Formula, 2) & "/" & _
Mid(.Formula, 3, 2) & "/" & Right(.Formula, 2)
Case 7 ' e.g., 1121998 = 11-Feb-1998 NOT 1-Dec-1998
DateStr = Left(.Formula, 2) & "/" & _
Mid(.Formula, 3, 1) & "/" & Right(.Formula, 4)
Case 8 ' e.g., 11121998 = 11-Dec-1998
DateStr = Left(.Formula, 2) & "/" & _
Mid(.Formula, 3, 2) & "/" & Right(.Formula, 4)
Case Else
Err.Raise 0
End Select
.Formula = DateValue(DateStr)
End If
End With
Application.EnableEvents = True
Exit Sub
EndMacro:
MsgBox "You did not enter a valid date."
Application.EnableEvents = True
End Sub
--
Regards
Norman Harker MVP (Excel)
Sydney, Australia
Excel and Word Function Lists (Classifications, Syntax and
Arguments)
available free to good homes.