尝试 运行 工作表更改事件两次

Trying to run a worksheet change event twice

我正在尝试 运行 两个不同列 (A) 和 (I) 的工作表更改事件...

    Private Sub Worksheet_Change(ByVal Target As Range)
        Dim A As Range, B As Range, Inte As Range, r As Range
        Set A = Range("A:A")
        Set Inte = Intersect(A, Target)
        If Inte Is Nothing Then Exit Sub
        Application.EnableEvents = False
            For Each r In Inte
                r.Offset(0, 1).Value = Date
            Next r
        Application.EnableEvents = True 
    End Sub

这个活动是我在这个论坛上找到的。它的目的是让数据在 "a" 列中输入时,它会自动将日期直接输入到它右侧的单元格中。我希望这在工作表上发生两次。我不知道如何 change/add 。我正在尝试将其设为 运行 电子表格中 A 列和 I 列的逻辑。

只需扩大您为 A 变量设置的范围即可。

Set A = Range("A:A, I:I")

重写为,

Private Sub Worksheet_Change(ByVal Target As Range)
    if not intersect(range("A:A, I:I"), target) is nothing then
        'add error control
        on error goto safe_exit
        'don't do anything until you know something has to be done
        dim r as range
        Application.EnableEvents = False
        For Each r In intersect(range("A:A, I:I"), target)
            r.Offset(0, 1).Value = Date   'do you want Date or Now?
        Next r
    end if
safe_exit:
    Application.EnableEvents = True 
End Sub

在 OP 评论后编辑

扩展@Jeeped 解决方案,您可以避免循环:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range

    Set rng = Intersect(Range("A:A, I:I"), Target) ' define range of interest
    If Not rng Is Nothing Then ' check it's not "nothing"
        If WorksheetFunction.CountA(rng) = rng.Count Then 'check for all of its cells being not empty
            On Error GoTo safe_exit 'add error control
            Application.EnableEvents = False 'don't do anything until you know something has to be done
            rng.Offset(, 1).Value = Date 'write Date next to all relevant changed cells
        End If
    End If

safe_exit:
    Application.EnableEvents = True
End Sub