vba目标与添加注释相交 - 对象错误msg

Question

我有以下代码片段，它可以很好地发挥我所使用的功能。在调试可能的结果时，我发现，例如，如果我尝试通过ADDING或DELETING A ROW来更改TARGET范围，我会得到一个VBA错误：

如果我在target-> i中添加一行， “ - ＃424 如果我删除目标中的一行 - >我得到”方法撤消对象应用程序失败“ - ＃1001（我知道这是由于我使用UNDO来获取旧的单元格值，知道如何解决）

Option Explicit 

Private Sub Worksheet_Change(ByVal target As Range) 

Dim newvalue As Variant 
Dim oldvalue As Variant 
Dim cell As Range 
Dim trg As String 

' to replace current comment with new one 

'If Target.Address = "$A$1" Then 
'MsgBox "new value " & newvalue & vbLf & "old value " & oldvalue 
' If ActiveCell.Comment Is Nothing Then 
' ActiveCell.AddComment ("Old Value: " & oldvalue & vbNewLine & "New Value: " & newvalue) 
' Else 
' ActiveCell.Comment.Delete 
' ActiveCell.AddComment ("Old Value: " & oldvalue & vbNewLine & "New Value: " & newvalue) 
' End If 

'to append comments to existing comment 

On Error GoTo ermess 

If Not Application.Intersect(target, Range("A1", "A10")) Is Nothing Then 

    For Each cell In target 

     Application.EnableEvents = False 
     newvalue = cell.Value 
     Application.Undo 
     oldvalue = cell.Value 
     cell.Value = newvalue 
     Application.EnableEvents = True 
     cell.Interior.ColorIndex = 19 

        If newvalue <> oldvalue Then 

         ' If (Target.Address = "$A$1") Then 
         MsgBox "new value " & newvalue & vbLf & "old value " & oldvalue 

          If cell.Comment Is Nothing Then 
          cell.AddComment ("Old Value: " & oldvalue & vbNewLine & "New Value: " & newvalue & vbNewLine & "Updated: " & Now & vbNewLine & "By: " & Environ("username")) 
          Else 
          With target 
          .Comment.Text Text:=.Comment.Text & vbNewLine & ("Old Value: " & oldvalue & vbNewLine & "New Value: " & newvalue & vbNewLine & "Updated: " & Now _ 
          & vbNewLine & "By: " & Environ("username")) 
          End With 

          End If 

         'End If 

        Else 
0 
        End If 
        'Set target = Nothing 

     Next cell 
Else 

'to test if not in the target specified 
'MsgBox "Not in range" 

End If 

'Application.EnableEvents = True 

Exit Sub 
ermess: 
MsgBox "VBA Error" & vbLf & Err.Description & vbLf & Err.Number, vbCritical 

'Debug.Print 
Application.EnableEvents = True 

End Sub 

我想这样做的“对象所需”消息，如果有可能消除它重置范围。

关于“应用程序撤消”消息 - >我知道使用它来检索单元格的先前值不是最好的方法，但它对我很有用，所以如果有解决方案，被期望。

我不想使用“On error resume next”，因为我想先清理代码。

谢谢

Answer 1

我找到了解决方案。对于任何感兴趣的人，我添加了一条评估目标范围计数的if语句（如果> 1，则退出分类）

Option Explicit 

Private Sub worksheet_change(ByVal target As Range) 

Dim newvalue As Variant 
Dim oldvalue As Variant 
Dim rng2 As Range 
Dim cell As Range 
Dim trg As String 

' to replace current comment with new one 

'If Target.Address = "$A$1" Then 
'MsgBox "new value " & newvalue & vbLf & "old value " & oldvalue 
' If ActiveCell.Comment Is Nothing Then 
' ActiveCell.AddComment ("Old Value: " & oldvalue & vbNewLine & "New Value: " & newvalue) 
' Else 
' ActiveCell.Comment.Delete 
' ActiveCell.AddComment ("Old Value: " & oldvalue & vbNewLine & "New Value: " & newvalue) 
' End If 

'to append comments to existing comment 

Set rng2 = ActiveSheet.Range("A1:A11") 

On Error GoTo ermess 

    **If target.Count <= 1 Then 'Exit Sub** 

     If Not Application.Intersect(target, rng2) Is Nothing Then 

      For Each cell In target 

      ' On Error Resume Next 
      Application.EnableEvents = False 
      newvalue = cell.Value 
      Application.Undo 
      oldvalue = cell.Value 
      cell.Value = newvalue 
      'On Error GoTo ExitProc 
      Application.EnableEvents = True 
      cell.Interior.ColorIndex = 19 

      '   If newvalue <> Empty Then 

         If newvalue <> oldvalue Then 

          ' If (Target.Address = "$A$1") Then 
          MsgBox "new value " & newvalue & vbLf & "old value " & oldvalue 

           If cell.Comment Is Nothing Then 
           cell.AddComment ("Old Value: " & oldvalue & vbNewLine & "New Value: " & newvalue & vbNewLine & "Updated: " & Now & vbNewLine & "By: " & Environ("username")) 
           Else 
           With target 
           .Comment.Text Text:=.Comment.Text & vbNewLine & ("Old Value: " & oldvalue & vbNewLine & "New Value: " & newvalue & vbNewLine & "Updated: " & Now _ 
           & vbNewLine & "By: " & Environ("username")) 
           End With 

           End If 

          'End If 

         Else 
0 
         End If 
         'Set target = Nothing 

       '  End If 

      Next cell 

     End If 
    'to test if not in the target specified 
    'MsgBox "Not in range" 
    ***Else 
    Exit Sub 
    End If*** 

With Application 
    .EnableEvents = True 
    .ScreenUpdating = True 
End With 

Exit Sub 
ermess: 
MsgBox "VBA Error" & vbLf & Err.Description & vbLf & Err.Number, vbCritical 

'Debug.Print 

End Sub