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

输入没有斜线的日期

1 个答案: