將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

在一個模塊的兩個子過程中實現它，然后只需在事件過程中調用它們。