Entering Dates Without Slashes - vba

Question

I sometimes have to enter a lot of dates in Excel spreadsheets. Having to enter the slashes slows things down a lot and makes the process more error prone. On many database programs, it is possible to enter the dates using only the numbers.
I have written a SheetChange event handler that lets me do this when entering dates in cells formatted as dates, but it fails if I copy a date from one location to another. If I could determine when an entry has been copied as opposed to entered, I could handle the two cases separately, but I have not been able to determine this yet.
Here is my code, but before you look at it, be aware that the last section handles inserting a decimal point automatically and it seems to be working ok. Finally, I added some variables (sValue, sValue2, etc.) to make it a little easier for me to track the data.
Option Explicit
Private WithEvents App As Application
Private Sub Class_Initialize()
Set App = Application
End Sub
Private Sub App_SheetChange(ByVal Sh As Object, ByVal Source As Range)
Dim s As String
Dim sFormat As String
Dim sValue As String
Dim sValue2 As String
Dim sFormula As String
Dim sText As String
Dim iPos As Integer
Dim sDate As String
On Error GoTo ErrHandler:
If Source.Cells.Count > 1 Then
Exit Sub
End If
If InStr(Source.Formula, "=") > 0 Then
Exit Sub
End If
sFormat = Source.NumberFormat
sFormula = Source.Formula
sText = Source.Text
sValue2 = Source.Value2
sValue = Source.Value
iPos = InStr(sFormat, ";")
If iPos > 0 Then sFormat = Left(sFormat, iPos - 1)
If InStr("m/d/yy|m/d/yyyy|mm/dd/yy|mm/dd/yyyy|mm/dd/yy", sFormat) > 0 Then
If IsDate(Source.Value2) Then
Exit Sub
End If
If IsNumeric(Source.Value2) Then
s = CStr(Source.Value2)
If Len(s) = 5 Then s = "0" & s
If Len(s) = 6 Then
s = Left(s, 2) & "/" & Mid(s, 3, 2) & "/" & Right(s, 2)
App.EnableEvents = False
If IsDate(s) Then Source.Value = s 'else source is unchanged
App.EnableEvents = True
End If
If Len(s) = 7 Then s = "0" & s
If Len(s) = 8 Then
s = Left(s, 2) & "/" & Mid(s, 3, 2) & "/" & Right(s, 4)
App.EnableEvents = False
If IsDate(s) Then Source.Value = s 'else source is unchanged
App.EnableEvents = True
End If
End If
End If
If InStr(sFormat, "0.00") > 0 Then
If IsNumeric(Source.Formula) Then
s = Source.Formula
If InStr(".", s) = 0 Then
s = Left(s, Len(s) - 2) & "." & Right(s, 2)
App.EnableEvents = False
Source.Formula = CDbl(s)
App.EnableEvents = True
End If
End If
End If
ErrHandler:
App.EnableEvents = True
End Sub
Do you know how I can get this to work for copied dates as well as edited dates? Thanks for your help.

Answer 1

Actually, the event Worksheet_Change is called when copy/pasting, so it should work.
Just tested with:
Private Sub Worksheet_Change(ByVal Target As Range)
MsgBox "Test"
End Sub