Entering Dates Without Slashes

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)开发者_Python百科
        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.

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