Ввод дат без косых черт

Question

Мне иногда приходится вводить много дат в электронные таблицы Excel. Необходимость ввода косых черт сильно замедляет работу и делает процесс более подверженным ошибкам. Во многих программах баз данных можно вводить даты, используя только цифры.

Я написал обработчик событий SheetChange, который позволяет мне это делать при вводе дат в ячейках, отформатированных как даты, но не получается, если я копирую дату из одного местоположения в другое. Если бы я мог определить, когда запись была скопирована, а не введена, я мог бы обработать два случая отдельно, но я пока не смог определить это.

Вот мой код, но прежде чем вы посмотрите на него, имейте в виду, что последний раздел обрабатывает автоматическую вставку десятичной точки, и кажется, что она работает нормально. Наконец, я добавил несколько переменных (sValue, sValue2 и т. Д.), Чтобы мне было легче отслеживать данные.

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

Знаете ли вы, как я могу заставить это работать как для копируемых, так и для отредактированных дат? Спасибо за вашу помощь.

Answer 1

На самом деле событие Worksheet_Change вызывается при копировании / вставке, поэтому оно должно работать.

Только что протестировано с:

Private Sub Worksheet_Change(ByVal Target As Range)
    MsgBox "Test"
End Sub