Question

我有一个电子表格，在单元格A2-A999中有数据验证，下拉菜单中的唯一选项是＆＃34;今天＆＃34; （不带引号）。我有一个VBA代码，可以将单元格的值更改为今天＆＃34;今天＆＃34;在单元格中选择。但是，此代码存在问题。当我清除一组单元格的内容，包括其中包含今天日期的单元格时，电子表格会思考，然后调试然后关闭;例如清算A1和B1同时。但是，如果我自己清除A1，它会毫无问题地清除单元格。

P.S。通过＆＃34;我清楚＆＃34;，我的意思是说：＆＃34;我用鼠标选择了一组单元格然后点击退格按钮。＆＃34;

你们可以帮我修复代码，这样我就可以同时清除多个单元格，包括带有数据验证的单元格。

我正在使用的代码粘贴在工作表部分中，如下所示：

Private Sub Worksheet_Change(ByVal Target As Range)

  selectedVal = Target.Value

If Target.Column = 1 Then
    selectedNum = Application.VLookup(selectedVal, Worksheets("DATA-
O").Range("DateToday"), 2, False)

    If Not IsError(selectedNum) Then
        Target.Value = selectedNum
    End If
    End If
End Sub

Answer 1

您的问题的答案是（正如Dirk Reichel在评论中提到的那样）循环遍历每个受影响的单元格：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    If Not Intersect(Columns(1), Target) Is Nothing Then
        For Each c In Intersect(Columns(1), Target).Cells
            selectedVal = c.Value
            selectedNum = Application.VLookup(selectedVal, Worksheets("DATA-O").Range("DateToday"), 2, False)    
            If Not IsError(selectedNum) Then
                Application.EnableEvents = False 'As recommended by K Paul
                c.Value = selectedNum
                Application.EnableEvents = True
            End If
        Next
    End If
End Sub

但是，根据您所说的代码所做的事情，我不确定您为什么不使用该代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    If Not Intersect(Columns(1), Target) Is Nothing Then
        For Each c In Intersect(Columns(1), Target).Cells
            If c.Value = "Today" Then
                Application.EnableEvents = False 'As recommended by K Paul
                c.Value = Date
                Application.EnableEvents = True
            End If
        Next
    End If
End Sub

Answer 2

如果你想要快，有两种方法。

使用Evaluate像数组一样：

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Columns(1), Target) Is Nothing Then
    With Intersect(Columns(1), Target)
      If Evaluate("AND(" & .Address & "<>""Today"")") Then Exit Sub
      .Value = Evaluate("IF(" & .Address & "=""Today"",TODAY()," & .Address & ")")
    End With
  End If
End Sub

或使用Range.Replace也可以非常快：

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Columns(1), Target) Is Nothing Then
    Intersect(Columns(1), Target).Replace "Today", Date, xlWhole, , True, , False, False
  End If
End Sub

一个小提示：点击 ctrl ＆amp; ; 将直接输入今天的日期

今天数据验证中的日期Vba代码

2 个答案: