vba cible se croisent avec des commentaires ajoutés - erreur d'objet msg

Question

J'ai le morceau de code suivant qui fonctionne très bien compte tenu de ce que je l'ai utilisé pour. Dans le débogage des résultats possibles, j'ai trouvé que, par exemple si j'essaie de modifier la plage TARGET soit en ajoutant ou en supprimant une ligne, j'obtiens une erreur VBA:

Si j'ajoute une ligne dans target-> i get "Object Required "- # 424 Si je supprime une ligne dans target -> j'obtiens" Method Undo de l'application Object Failed "- # 1001 (Je sais que cela est dû au fait que j'utilise UNDO pour obtenir l'ancienne valeur de la cellule, mais don ' sais comment résoudre)

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 

ce que je veux le faire pour réinitialiser la plage de sorte que le message « objet requis » est éliminé si possible. En ce qui concerne le message "Annuler l'application" -> Je sais que l'utilisation de ceci pour récupérer une valeur précédente d'une cellule n'est pas la meilleure méthode, mais cela a fonctionné pour moi, donc s'il y a une solution à ce problème. être désiré.

Je ne souhaite pas utiliser "En cas de reprise d'erreur suivante" car je souhaite d'abord nettoyer le code.

Merci

Answer 1

J'ai trouvé la solution. Pour toute personne intéressée, j'ai ajouté une instruction if qui évaluait le nombre de plages cibles (si> 1, puis quittez le sous-champ)

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