将2个“ Private Sub Worksheet_Change（按目标的ByVal目标）”合并为1个

Question

我正在创建一个Excel电子表格。 我有2个需要组合的独立功能，但不确定如何将它们粉碎在一起。 我知道我只能有1次变更事件。 第一个功能将取消保护工作表的保护（列c被锁定），将数据输入到列A中时自动填充列C，或者当擦除A时自动填充C，并在完成后重新保护。 当将数据输入到A和B中时，第二个将使单元格焦点返回到下一行A列。它们分别根据需要工作。

    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Unprotect Password:="my password"
    If Target.Column = 1 Then
        Dim A As Range, B As Range, Inte As Range, r As Range
       Set A = Range("A:A")
       Set Inte = Intersect(A, Target)
    If Target.Offset(0, 1 - Target.Column).Value = "" Then
        Target.Offset(0, 3 - Target.Column).Clear
        Exit Sub
    End If
    Application.EnableEvents = False
    For Each r In Inte
    r.Offset(0, 2).Value = Date & " " & Time
    r.Offset(0, 2).NumberFormat = "m/d/yyyy h:mm am/pm"
    Next r
    Application.EnableEvents = True       
    End If
    Protect Password:="my password"
    End Sub


    Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Whoa
    Application.EnableEvents = False
    If Not Target.Cells.CountLarge > 1 Then
    If Not Intersect(Target, Columns(1)) Is Nothing Then
        Target.Offset(, 1).Select
    ElseIf Not Intersect(Target, Columns(2)) Is Nothing Then
        Target.Offset(1, -1).Select
    End If
    End If
    Letscontinue:
    Application.EnableEvents = True
    Exit Sub
    Whoa:
    MsgBox Err.Description
    Resume Letscontinue
    End Sub

Answer 1

据我了解的问题，这似乎在做什么？

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rngIntersect    As Range
    Dim rngCell         As Range

    On Error GoTo TidyUp

    Application.EnableEvents = False

    If Target.Column = 1 Then

        Set rngIntersect = Intersect(Range("A:A"), Target)

        For Each rngCell In rngIntersect
            If rngCell.Value = "" Then
                rngCell.Offset(0, 2).Value = ""
            Else
                rngCell.Offset(0, 2).Value = Date & " " & Time
                rngCell.Offset(0, 2).NumberFormat = "m/d/yyyy h:mm am/pm"
            End If
        Next rngCell
    End If

    If Target.Column < 3 And Target.Value <> "" Then  ' lose the 'And Target.Value <> ""' as desired
        Cells(Target.Row + Target.Rows.Count, 1).Select
    End If

TidyUp:

    Set rngIntersect = Nothing
    Set rngCell = Nothing

    Application.EnableEvents = True

End Sub

我还建议您在worksheet.Protect中使用UserInterfaceOnly，然后不必为VBA取消保护工作表即可在工作表上执行操作。

Answer 2

在一个模块的两个子过程中实现它，然后只需在事件过程中调用它们。