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

Question

我有以下代码，鉴于我使用的代码非常有效。在调试可能的结果时，我发现例如，如果我尝试通过添加或删除行更改目标范围，则会获得VBA错误：

如果我在target->中添加一行，我会得到"必需对象" - ＃424如果我在目标中删除一行 ->我得到"撤消对象应用程序的方法失败" - ＃1001(我知道这是由于我正在使用撤消来获取旧单元格值的事实，但不知道如何解决(

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

我想做的以重置范围，以便在可能的情况下消除"对象"的消息。

关于"应用程序撤消"消息 ->我知道，我知道使用它来检索单元格的先前值不是最好的方法，但它对我有用，因此，如果对此有解决方案想要的。

我不想使用"下一步错误简历"，因为我想先清理代码。

谢谢

Answer 1

我找到了解决方案。对于有兴趣的任何人，我添加了一个评估目标范围计数的IF语句(如果> 1，然后退出Sub(

(

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