XL 2019 Rapprochement

[iliess]

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

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

 

[JHA]

Bonjour à tous,

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

JHA

 

[mapomme]

Bonjour @iliess, @JHA ,

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

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]

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.