XL 2013 Formule Excel pour annuler/extraire les écritures qui s'annulent entre elles.

[Targui]

bonjour

ma question est la suivante :

je dispose d'un journal comptable établi sous Excel 2000

ce journal renferme plusieurs milliers d'enregistrement comptables.

je voudrais connaître, s'il existe une commande ou instruction spécifique me permettant d'eliminer tous les enregistrements ayant un solde nul (ie. débit positif , crédit négatif pour un même montant)

ex: enregistrement (ligne 1) .... .... ..... +1 000,00
enregistrement (ligne 2) .... .... ..... - 1 000,00
enregistrement (ligne 3) .... .... ..... +5 000,00
enregistrement (ligne 4) .... .... ..... +8 500,00

résultat recherché : .... .... .... +5 000,00
.... .... .... +8 500,00

NB : les enregistrements dont les montants s'annulent ne doivent pas apparaitre sur le journal.

 

[job75]

Re : Formule Excel pour annuler/extraire les écritures qui s'annulent entre elles.

Bonjour Targui, mapomme,

Dans ce fichier (1 bis) j'ai ajouté le texte de la colonne M (13) comme critère de comparaison :

'---comptage des négatifs et positifs---
  Set dneg = CreateObject("Scripting.Dictionary")
  Set dpos = CreateObject("Scripting.Dictionary")
  s = Chr(1)
  For i = 1 To nlig
    x = t(i, 1) & s & LCase(t(i, 13)) & s & Replace(t(i, col), "-", "") 'avec texte colonne M
    t(i, ncol) = x 'mémorisation
    If t(i, col) < 0 Then dneg(x) = dneg(x) + 1 Else dpos(x) = dpos(x) + 1
  Next i

Edit : LCase permet d'ignorer la casse.

Les 4 valeurs 100000 en colonnes F ne sont plus supprimées.

A+

 

[job75]

Re : Formule Excel pour annuler/extraire les écritures qui s'annulent entre elles.

Re,

Je disais au post #14 :

Et les copies, le tri, les suppressions ne sont guère compressibles.

Eh si, en continuant avec des tableaux VBA (t1 et t2) :

Sub Journal()
'se lance par Ctrl+A
Dim col%, F1 As Worksheet, F2 As Worksheet, nlig&, ncol%, t, t1(), t2()
Dim dneg As Object, dpos As Object, s$, i&, x$, dneg1 As Object, dpos1 As Object
Dim n&, flag As Boolean, n1&, j%, n2&
col = 4 'n° de colonne des montants, à adapter
Set F1 = Sheets("Journal") 'nom à adapter
Set F2 = Sheets("Supprimé") 'nom à adapter
With [A1].CurrentRegion
  nlig = .Rows.Count
  ncol = .Columns.Count
  t = .Resize(nlig, ncol + 1) '1 colonne de plus
  ReDim t1(1 To nlig, 1 To ncol)
  ReDim t2(1 To nlig, 1 To ncol)
End With
'---comptage des négatifs et positifs---
Set dneg = CreateObject("Scripting.Dictionary")
Set dpos = CreateObject("Scripting.Dictionary")
s = Chr(1)
For i = 1 To nlig
  x = t(i, 1) & s & Replace(t(i, col), "-", "")
  t(i, ncol + 1) = x 'mémorisation
  If t(i, col) < 0 Then dneg(x) = dneg(x) + 1 Else dpos(x) = dpos(x) + 1
Next
'---repérage des paires et remplissage des tableaux t1 et t2---
Set dneg1 = CreateObject("Scripting.Dictionary")
Set dpos1 = CreateObject("Scripting.Dictionary")
For i = 1 To nlig
  x = t(i, ncol + 1)
  n = IIf(dneg(x) < dpos(x), dneg(x), dpos(x))
  flag = True
  If t(i, col) < 0 Then
    If dneg1(x) < n Then dneg1(x) = dneg1(x) + 1: flag = False 'repèrage
  Else
    If dpos1(x) < n Then dpos1(x) = dpos1(x) + 1: flag = False 'repèrage
  End If
  If flag Then
    n1 = n1 + 1
    For j = 1 To ncol: t1(n1, j) = t(i, j): Next
  Else
    n2 = n2 + 1
    For j = 1 To ncol: t2(n2, j) = t(i, j): Next
  End If
Next
'---restitution---
F1.[A1].Resize(n1, ncol) = t1
F1.Rows(n1 + 1 & ":" & F1.Rows.Count).Delete
If n2 Then F2.[A2].Resize(n2, ncol) = t2
F2.Rows(n2 + 2 & ":" & F2.Rows.Count).Delete
With F1.UsedRange: End With: With F2.UsedRange: End With
MsgBox "Les feuilles '" & F1.Name & "' et '" & F2.Name & "' ont été mises à jour"
End Sub

J'ai mis col = 4 pour être exactement dans les conditions du fichier de mapomme (post #15).

Durées d'exécution sur mon ordi Win 8 - Excel 2013 :

- avec 7000 lignes - job 75 => 0,5 s - mapomme 0,5 s

- avec 49000 lignes - job75 => 3,3 s - mapomme => 2,8 s, c'est mieux

A+

 

[job75]

Re : Formule Excel pour annuler/extraire les écritures qui s'annulent entre elles.

Bonjour Targui, le forum,

Si le tableau n'a que quelques milliers de lignes, la macro s'exécute en quelques 1/10èmes de secondes.

Il est donc plus simple de la faire exécuter par :

Private Sub Worksheet_Activate()
Feuil1.Journal 'CodeName de la feuille
End Sub

La macro se simplifie et la durée d'exécution est plus courte :

Sub Journal()
Dim col%, journ As Boolean, suppr As Boolean, nlig&, ncol%, t
Dim dneg As Object, dpos As Object, s$, i&, x$, dneg1 As Object, dpos1 As Object
Dim n&, flag As Boolean, n1&, j%
col = 4 'n° de colonne des montants, à adapter
journ = ActiveSheet.Name = "Journal" 'nom à adapter
suppr = ActiveSheet.Name = "Supprimé" 'nom à adapter
If Not journ And Not suppr Then Exit Sub
With [A1].CurrentRegion
  nlig = .Rows.Count
  ncol = .Columns.Count
  t = .Resize(nlig, ncol + 1) '1 colonne de plus
End With
'---comptage des négatifs et positifs---
Set dneg = CreateObject("Scripting.Dictionary")
Set dpos = CreateObject("Scripting.Dictionary")
s = Chr(1)
For i = 1 To nlig
  x = t(i, 1) & s & Replace(t(i, col), "-", "")
  t(i, ncol + 1) = x 'mémorisation
  If t(i, col) < 0 Then dneg(x) = dneg(x) + 1 Else dpos(x) = dpos(x) + 1
Next
'---repérage des paires et re-remplissage du tableau t---
Set dneg1 = CreateObject("Scripting.Dictionary")
Set dpos1 = CreateObject("Scripting.Dictionary")
For i = 1 To nlig
  x = t(i, ncol + 1)
  n = IIf(dneg(x) < dpos(x), dneg(x), dpos(x))
  flag = journ
  If t(i, col) < 0 Then
    If dneg1(x) < n Then dneg1(x) = dneg1(x) + 1: flag = Not flag 'repèrage
  Else
    If dpos1(x) < n Then dpos1(x) = dpos1(x) + 1: flag = Not flag 'repèrage
  End If
  If flag Then
    n1 = n1 + 1
    For j = 1 To ncol: t(n1, j) = t(i, j): Next
  End If
Next
'---restitution---
With ActiveSheet
  If journ Then
    .[A1].Resize(n1, ncol) = t
    .Rows(n1 + 1 & ":" & .Rows.Count).Delete
  ElseIf n1 Then
    .[A2].Resize(n1, ncol) = t
    .Rows(n1 + 2 & ":" & .Rows.Count).Delete
  End If
  With .UsedRange: End With
End With
End Sub

Fichier (3) avec 7000 lignes.

Edit : fichier (3 bis) meilleur avec en fin de macro :

'---restitution---
With ActiveSheet
  If journ Then
    .[A1].Resize(n1, ncol) = t
    .Rows(n1 + 1 & ":" & .Rows.Count).Delete
  Else
    If n1 Then .[A2].Resize(n1, ncol) = t
    .Rows(n1 + 2 & ":" & .Rows.Count).Delete
  End If

Nota : on vérifiera que dans la feuille "Journal" on a bien NB.SI(F:F;-24000) = 200.

Et dans la feuille "Supprimé" NB.SI(F:F;24000) = NB.SI(F:F;-24000) = 200.

A+

 

[job75]

Re : Formule Excel pour annuler/extraire les écritures qui s'annulent entre elles.

Bonjour le forum,

Je viens de recevoir (mieux vaut tard que jamais) par MP (?!) ces précisions :

Seulement, ce qui m'aurait plus arrangé c'est que votre formule puisse utiliser la colonne L (colonne DEA) pour que les transactions qui ont le même DEA, le même libellé "colonne M text" ainsi que les montants (positifs et négatifs) de la colonne F "trans cur Amt" qui s'annulent entre eux.

Il suffisait de modifier le calcul de x à la 19ème ligne :

Sub Journal()
Dim col%, journ As Boolean, suppr As Boolean, nlig&, ncol%, t
Dim dneg As Object, dpos As Object, s$, i&, x$, dneg1 As Object, dpos1 As Object
Dim n&, flag As Boolean, n1&, j%
col = 6 'n° de colonne des montants, à adapter
journ = ActiveSheet.Name = "Journal" 'nom à adapter
suppr = ActiveSheet.Name = "Supprimé" 'nom à adapter
If Not journ And Not suppr Then Exit Sub
With [A1].CurrentRegion
  nlig = .Rows.Count
  ncol = .Columns.Count
  t = .Resize(nlig, ncol + 1) '1 colonne de plus
End With
'---comptage des négatifs et positifs---
Set dneg = CreateObject("Scripting.Dictionary")
Set dpos = CreateObject("Scripting.Dictionary")
s = Chr(1)
For i = 1 To nlig
  x = t(i, 12) & s & UCase(t(i, 13)) & s & Replace(t(i, col), "-", "")
  t(i, ncol + 1) = x 'mémorisation
  If t(i, col) < 0 Then dneg(x) = dneg(x) + 1 Else dpos(x) = dpos(x) + 1
Next
'---repérage des paires et re-remplissage du tableau t---
Set dneg1 = CreateObject("Scripting.Dictionary")
Set dpos1 = CreateObject("Scripting.Dictionary")
For i = 1 To nlig
  x = t(i, ncol + 1)
  n = IIf(dneg(x) < dpos(x), dneg(x), dpos(x))
  flag = journ
  If t(i, col) < 0 Then
    If dneg1(x) < n Then dneg1(x) = dneg1(x) + 1: flag = Not flag 'repèrage
  Else
    If dpos1(x) < n Then dpos1(x) = dpos1(x) + 1: flag = Not flag 'repèrage
  End If
  If flag Then
    n1 = n1 + 1
    For j = 1 To ncol: t(n1, j) = t(i, j): Next
  End If
Next
'---restitution---
With ActiveSheet
  If journ Then
    .[A1].Resize(n1, ncol) = t
    .Rows(n1 + 1 & ":" & .Rows.Count).Delete
  Else
    If n1 Then .[A2].Resize(n1, ncol) = t
    .Rows(n1 + 2 & ":" & .Rows.Count).Delete
  End If
  With .UsedRange: End With
End With
End Sub

Fichier (4).

A+

 

[Targui]

Re : Formule Excel pour annuler/extraire les écritures qui s'annulent entre elles.

Bonjour JOb75, bonjour le forum,

Merci pour cette solution proposée, elle a résolu mon problème!

Je voudrais à présent apprendre à utiliser les macros dans Excel car elles sont vraiment efficaces. Aussi, je vous saurais gréer de bien vouloir me partager un module pour débutant qui permettra m'y initier.

Encore merci!

Cordialement