Скопируйте и вставьте непреднамеренно триггер Worksheet_Change

Question

У меня проблемы с подпрограммой «Worksheet_Change», которая копирует и вставляет всю строку во второй лист («Завершено»), когда столбец «P» принимает значение «x».Это выглядит так:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
    Application.EnableEvents = False
    'If Cell that is edited is in column P and the value is x then
    If Target.Column = 16 And Target.Value = "x" Then
        'Define last row on completed worksheet to know where to place the row of data
        LrowCompleted = Sheets("Completed").Cells(Rows.Count, "A").End(xlUp).Row
        'Copy and paste data
        Range("A" & Target.Row & ":P" & Target.Row).Copy Sheets("Completed").Range("A" & LrowCompleted + 1)
        'Delete Row from Project List
        Range("A" & Target.Row & ":P" & Target.Row).Delete xlShiftUp
    End If
    Application.EnableEvents = True
End Sub

Сам саб работает нормально, но если я копирую и вставляю в любое место на рабочем листе, саб активируется, и строка, в которую я вставляю, отправляется на мой «Завершенный» лист.

Я пока что безуспешно играл с предложением if.Например:

    If Not Target.Column = 16 And Target.Value = "x" Is Nothing Then

Боюсь, что мне не хватает очевидного, и я благодарен за любую помощь.

Спасибо и всего наилучшего

PMHD

Answer 1

Если вас интересуют несколько целей, разберитесь с ними;не выбрасывайте их.

Private Sub Worksheet_Change(ByVal Target As Range)

  If not intersect(target, range("p:p")) is nothing then
        on error goto meh
        Application.EnableEvents = False
        dim t as range, lrc as long
        lrc = workSheets("Completed").Cells(Rows.Count, "A").End(xlUp).Row + 1
        for each t in intersect(target, range("p:p"))
            if lcase(t.Value2) = "x" Then
                intersect(columns("A:P"), t.rows(t.row)).Copy _
                    destination:=workSheets("Completed").cells(lrc , "A")
                lrc = lrc+1
                'Delete Row from Project List
                intersect(columns("A:P"), t.rows(t.row)).Delete xlShiftUp
             end if
        next t
    End if

meh:
    Application.EnableEvents = true

end sub

Answer 2

Спасибо, Джипед.

Проблема возникла из-за того, что Target ссылается на несколько ячеек.Это было исправлено исключением случаев, когда Target.Count> 1.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
'Exclude all cases where more than one cell is Target
If Target.Count > 1 Then

'If Cell that is edited is in column P and the value is x then
ElseIf Target.Column = 16 And Target.Value = "x" Then
    'Define last row on completed worksheet to know where to place the row of data
    LrowCompleted = Sheets("Completed").Cells(Rows.Count, "A").End(xlUp).Row
    'Copy and paste data
    Range("A" & Target.Row & ":P" & Target.Row).Copy Sheets("Completed").Range("A" & LrowCompleted + 1)
    'Delete Row from Project List
    Range("A" & Target.Row & ":P" & Target.Row).Delete xlShiftUp
End If
Application.EnableEvents = True
End Sub