复制和粘贴无意中触发 Worksheet_Change 子
Copy & paste inadvertently triggers Worksheet_Change sub
我在使用 "Worksheet_Change" 子程序时遇到问题,该子程序将整行复制并粘贴到第二个作品中 sheet ("Completed") 当列 "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
sub 本身工作正常,但如果我复制并粘贴作品中的任何地方sheet,sub 将被激活,我粘贴的行将发送到我的 "Completed" sheet.
到目前为止,我一直在尝试 "if-clause",但运气不佳。例如:
If Not Target.Column = 16 And Target.Value = "x" Is Nothing Then
恐怕我遗漏了显而易见的东西,我很感激任何帮助。
感谢和问候
PMHD
谢谢,吉普车。
问题是由于 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
如果你关心多个目标,处理它们;不要丢弃它们。
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
我在使用 "Worksheet_Change" 子程序时遇到问题,该子程序将整行复制并粘贴到第二个作品中 sheet ("Completed") 当列 "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
sub 本身工作正常,但如果我复制并粘贴作品中的任何地方sheet,sub 将被激活,我粘贴的行将发送到我的 "Completed" sheet.
到目前为止,我一直在尝试 "if-clause",但运气不佳。例如:
If Not Target.Column = 16 And Target.Value = "x" Is Nothing Then
恐怕我遗漏了显而易见的东西,我很感激任何帮助。
感谢和问候
PMHD
谢谢,吉普车。
问题是由于 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
如果你关心多个目标,处理它们;不要丢弃它们。
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