XL 2019 Rapprochement

iliess · 20 Juin 2020

Bonjour
j'ai deux comptables
le premier constate les Achats son journal de saisie est ACH
le deuxième régler les Achats son journal de saisie est BQD

A la fin du mois je souhaite a voir les Achats non régler.
voici mon tableau

après la constatation le libelle du comptable ACH et automatiser comme suivant :
code fournisseur 5carac - Objet de la facture
après le paiement le libelle du comptable BQD et automatiser comme suivant :
code fournisseur 5carac -Date/N°orde de virement N°de la pièce de constatation Ach

voici un exemple

Au début ma macro marche très bien mais avec le temps le nombre de ligne et devenu très grand ( plus de 40000 lignes ) et son exécution est très lonte

Code:

Option Explicit
Sub Rapprochement()
Dim Dl As Long, I As Long, J As Long

With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
End With
Dl = ActiveSheet.Cells(Application.Rows.Count, 8).End(xlUp).Row - 1


    For I = 9 To Dl
        
        If Range("C" & I) = "BQD" Then
            Range("I" & I).FormulaLocal = "=CONCATENER(STXT(F" & I & ";CHERCHE(""/"";F" & I & ")+7;7);"" """ & ";SIERREUR(TEXTE(CNUM(GAUCHE(F" & I & ";TROUVE(""-"";F" & I & ")-1));""00000"");0);"" "";(G" & I & "+H" & I & "))"
        Else
            Range("I" & I).FormulaLocal = "=CONCATENER(D" & I & ";"" "";SIERREUR(TEXTE(CNUM(GAUCHE(F" & I & ";TROUVE(""-"";F" & I & ")-1));""00000"");0);"" "";(G" & I & "+H" & I & "))"
        End If
            
    Next I
    
    For I = 9 To Dl
        
        Range("J" & I).Formula = "=COUNTIF($i$9:$i$" & Dl & ",I" & I & ")"
        
    Next I
ActiveSheet.Range("$A$8:$J$" & Dl).AutoFilter
ActiveSheet.Range("$A$8:$J$" & Dl).AutoFilter Field:=10, Criteria1:="=2", Operator:=xlOr, Criteria2:="="
With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
End With
End Sub

J'ai essayer de travailler avec les tableau ou les collection ou les scripte j'ai lu que c'est plus rapide mais j'ai pas réussie

mapomme · 20 Juin 2020

Bonjour @iliess, @JHA ,

Un essai par macro sans doute plus rapide que la macro initiale.
Le code est dans Module1 :

VB:

Sub Rapprochement()
Dim derlig As Long, t, Dach, dBqd, clef, i&

With Sheets("Feuil3")
   Application.ScreenUpdating = False
   If .FilterMode Then .ShowAllData
   derlig = .Cells(Application.Rows.Count, 8).End(xlUp).Row - 1
   t = .Range("a8:h" & derlig).Value
   Set Dach = CreateObject("scripting.dictionary")
   Dach.CompareMode = TextCompare
   Set dBqd = CreateObject("scripting.dictionary")
   dBqd.CompareMode = TextCompare
   For i = 2 To UBound(t)
      If t(i, 3) = "ACH" Then
         clef = Join(Array(t(i, 4), Split(t(i, 6), "-")(0), t(i, 7) + t(i, 8)))
         If Not Dach.Exists(clef) Then...

JHA · 20 Juin 2020

Bonjour à tous,

Je ne suis pas certain de tout avoir compris, un essai en pièce jointe mode tableau et TCD

JHA

mapomme · 20 Juin 2020

Bonjour @iliess, @JHA ,

Un essai par macro sans doute plus rapide que la macro initiale.
Le code est dans Module1 :

VB:

Sub Rapprochement()
Dim derlig As Long, t, Dach, dBqd, clef, i&

With Sheets("Feuil3")
   Application.ScreenUpdating = False
   If .FilterMode Then .ShowAllData
   derlig = .Cells(Application.Rows.Count, 8).End(xlUp).Row - 1
   t = .Range("a8:h" & derlig).Value
   Set Dach = CreateObject("scripting.dictionary")
   Dach.CompareMode = TextCompare
   Set dBqd = CreateObject("scripting.dictionary")
   dBqd.CompareMode = TextCompare
   For i = 2 To UBound(t)
      If t(i, 3) = "ACH" Then
         clef = Join(Array(t(i, 4), Split(t(i, 6), "-")(0), t(i, 7) + t(i, 8)))
         If Not Dach.Exists(clef) Then Dach.Add clef, i
      ElseIf t(i, 3) = "BQD" Then
         clef = Join(Array(Split(t(i, 6))(1), Split(t(i, 6), "-")(0), t(i, 7) + t(i, 8)))
         If Not dBqd.Exists(clef) Then dBqd.Add clef, i
      End If
   Next i
   ReDim r(1 To UBound(t), 1 To 2)
   For Each clef In Dach
      r(Dach(clef), 1) = clef
      r(Dach(clef), 2) = 1
      If dBqd.Exists(clef) Then r(Dach(clef), 2) = r(Dach(clef), 2) + 1
   Next clef
   For Each clef In dBqd
      r(dBqd(clef), 1) = clef
      r(dBqd(clef), 2) = 1
      If Dach.Exists(clef) Then r(dBqd(clef), 2) = r(dBqd(clef), 2) + 1
   Next clef
   r(1, 1) = "Clef": r(1, 2) = "Qté"
   .Range("i8:j" & .Rows.Count).ClearContents
   .Range("i8").Resize(UBound(r), 2) = r
   .Range("i8").Resize(UBound(r), 2).Borders.LineStyle = xlContinuous
   If .AutoFilterMode Then .Cells.AutoFilter
   .Range("$A$8:$J$" & derlig).AutoFilter Field:=10, Criteria1:="=2", Operator:=xlOr, Criteria2:="="
End With
End Sub

iliess · 20 Juin 2020

Bonjour
votre code exécute 2000 lignes dans 2 seconde je suis entonnant.
Un merci c'est vraiment peux pour vous.
je vous dit Mille Merci Mille merci mille merci Monsieur.

XL 2019 Rapprochement

iliess

XLDnaute Occasionnel

Pièces jointes

mapomme

JHA

XLDnaute Barbatruc

Pièces jointes

mapomme

XLDnaute Barbatruc

Pièces jointes

iliess

XLDnaute Occasionnel

Discussions similaires