Supprimer des lignes qui s'annulent (positif /négatif) selon une condition

Bonjour à tous,

J'ai essayé de faire un Code VBA pour supprimer les lignes qui s'annulent (positif/ négatif) selon le même code ESI

Condition : Si même
ESI et que les factures sont inverses (ex : -1 et 1 euro ) alors suppression
des lignes car la somme est 0 euro

Code VBA

Sub MACRO()

Dim pl As Range 'déclare la variable pl
Dim cel1 As Range 'déclare la variable cel1
Dim cel2 As Range 'déclare la variable cel2
Dim a, i As Long, x As Range, e
With Sheets("Feuil1").Cells(1).CurrentRegion
.EntireRow.Interior.ColorIndex = xlNone

'définit la variable pl(ici toutes les cellules éditées de la colonne A)
Set pl = Range("A1:A" & Range("A65536").End(xlUp).Row)


For Each cel1 In pl 'boucle 1 : sur toutes les cellules cel2 de la plage pl
For Each cel2 In pl 'boucle 2 : sur toutes les cellules cel2 de la plage pl
If cel1.Value = cel2.Value Then 'condition : si les cellules sont identiques
a = .Value
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If a(i, 2) > 0 Then
.Item(i) = a(i, 2)
End If
Next
For i = 2 To UBound(a, 1)
If a(i, 2) < 0 Then
For Each e In .keys
If a(i, 2) + .Item(e) = 0 Then
If x Is Nothing Then
Set x = Union(Rows(i), Rows(e))
Else
Set x = Union(x, Rows(e), Rows(i))
End If
.Remove e: Exit For
End If
Next
End If
Next
End With
'supprime
'If Not x Is Nothing Then x.EntireRow.Delete
'surligne
If Not x Is Nothing Then x.Interior.ColorIndex = 44
End With
End Sub

Merci d'avance pour votre aide

Bonjour et bienvenue sur le forum

Un essai à tester. Te convient-il ?

Bye !

Bonjour,

Merci beaucoup pour avoir passé du temps sur ma demande mais je ne comprends pas pourquoi de la ligne 2 à 16, je n'ai pas le code ESI mais un nombre alors qu'à la ligne 17, le bon code ESI apparait :)

Nouvelle version

Bye !

Bonsoir à tous,

Essaie ceci :

Option Explicit
Sub supprime()
Dim a, i As Long, x As Range, e
    With Sheets("Feuil1").Cells(1).CurrentRegion
        .EntireRow.Interior.ColorIndex = xlNone
        a = .Value
        With CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(a, 1)
                If a(i, 2) > 0 Then
                    .Item(i) = a(i, 2)
                End If
            Next
            For i = 2 To UBound(a, 1)
                If a(i, 2) < 0 Then
                    For Each e In .keys
                        If a(i, 2) + .Item(e) = 0 Then
                            If x Is Nothing Then
                                Set x = Union(Rows(i), Rows(e))
                            Else
                                Set x = Union(x, Rows(e), Rows(i))
                            End If
                            .Remove e: Exit For
                        End If
                    Next
                End If
            Next
        End With
        'supprime
        'If Not x Is Nothing Then x.EntireRow.Delete
        'surligne
        If Not x Is Nothing Then x.Interior.ColorIndex = 44
    End With
End Sub

klin89

Bonjour, je vous remercie beaucoup :)