Comparaison de 2 tableaux avec modifications

Résolu
Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   -  
michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   -
Bonjour à tous.

On m'a aidé sur ce forum à créer un code qui compare 2 tableaux et fait des actions en fonction de ces comparaisons.

Voici le code :

Sub COMPARATIF()
Dim O1 As Worksheet 'déclare la variable O1 (Onglet 1)
Dim O2 As Worksheet 'déclare la variable O2 (Onglet 2)
Dim TC1 As Variant 'déclare la variable TC1 (Tableau de Cellules 1)
Dim TC2 As Variant 'déclare la variable TC2 (Tableau de Cellules 2)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Long 'déclare la variable J (incrément)
Dim TEST As Boolean 'déclare la variable TEST
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim TL() As Variant 'déclare la variable TL (Tableau de Lignes)
Dim T1 As String 'déclare la variable T1 (Texte 1)
Dim T2 As String 'déclare la variable T2 (Texte 2)
Dim K As Long 'déclare la variable K (incrément)

'*********************************************************************************
'copie les lignes du tableau 1 dans le tableau 2 (si manquantes dans le tableau 2)
'*********************************************************************************

Set O1 = Sheets(1) 'définit l'onglet O1 (à adapter)
Set O2 = Sheets(2) 'définit l'onglet O2 (à adapter)
TC1 = O1.Range("A3:J" & O1.Cells(Application.Rows.Count, 1).End(xlUp).Row) 'définit le tableau de cellules TC1 (à adapter, j'ai pris la colonne 1 comme référence pour la derniere ligne)
TC2 = O2.Range("A4:J" & O2.Cells(Application.Rows.Count, 1).End(xlUp).Row) 'définit le tableau de cellules TC2 (à adapter, j'ai pris la colonne 1 comme référence pour la derniere ligne)
For I = 1 To UBound(TC1, 1) 'boucle 1 : sur toutes les lignes I du tableau de cellules TC1
    TEST = False 'définit la variable TEST
    T1 = CStr(TC1(I, 3)) & "/" & CStr(TC1(I, 5)) & "/" & CStr(TC1(I, 10)) 'définit le texte T1 (concatenation des cellules colonnes 3, 5 et 10 = C, E et J)
    For J = 1 To UBound(TC2, 1) 'boucle 2 : pour toutes les lignes J du tableau de cellules TC2
        T2 = CStr(TC2(J, 3)) & "/" & CStr(TC2(J, 5)) & "/" & CStr(TC2(J, 10)) 'définit le texte T2 (concaténation des cellules colonnes 3, 5 et 10 = C, E et J)
        If T1 = T2 Then TEST = True: Exit For 'si T1 est égal à T2, TEST devient [Vrai], sort de la boucle 2
    Next J 'prochaine ligne de la boucle 2
    If TEST = False Then 'condition : si TEST est [FAUX]
        Set DEST = O2.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0) 'définit la cellule de destination (première ligne vide du tableau TC2)
        DEST.Resize(1, UBound(TC1, 2)) = Application.Index(TC1, I) 'récupère la ligne du tabelau TC1 dans DEST
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle 1

'****************************************************************
'efface les lignes du tableau 2 (si manquantes dans le tableau 1)
'****************************************************************

For I = 1 To UBound(TC2, 1) 'boucle 1 : sur toutes les lignes I du tableau de cellules TC2
    TEST = False 'définit la variable TEST
    T2 = CStr(TC2(I, 3)) & "/" & CStr(TC2(I, 5)) & "/" & CStr(TC2(I, 10)) 'définit le texte T2 (concaténation des cellules colonnes 3, 5 et 10 = C, E et J)
    For J = 1 To UBound(TC1, 1) 'boucle 2 : sour toutes les lignes J du tableau de cellules TC1
        T1 = CStr(TC1(J, 3)) & "/" & CStr(TC1(J, 5)) & "/" & CStr(TC1(J, 10)) 'définit le texte T1 (concatenation des cellules colonnes 3, 5 et 10 = C, E et J)
        If T2 = T1 Then TEST = True: Exit For 'si T2 est égal à T1, TEST devient [Vrai], sort de la boucle 2
    Next J 'prochaine ligne de la boucle 2
    If TEST = False Then 'condition : si TEST est [FAUX]
        ReDim Preserve TL(K) 'redimensionne le tableau TL
        TL(K) = I + 4 'récupère dans TL(K) le numéro de la ligne
        K = K + 1 'incrémente K
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle 1
If K > 0 Then 'condition : si K est supérieur à zéro
    For I = UBound(TL) To LBound(TL) Step -1 'boucle inversé de la dernière valeur du tableau TL à la première
        O2.Rows(TL(I)).Delete 'efface la ligne TL(I)
    Next I 'prochaine valeur de la boucle
End If 'fin de la condition


Voici le lien pour télécharger mon fichier anonymé :

https://www.cjoint.com/c/EFEjnUOyZ2f

Plus d'explications (même si le code parle de lui même) :

Le code est censé comparer les colonnes C, E et J de 2 tableaux en feuille 1 et en feuille 2 et en fonction de ces comparaisons, faire des actions.

- Si une ligne se trouve dans le tableau n°1 (feuille 1) et pas dans le tableau n°2 (feuille 2), alors, il faut ajouter la ligne au tableau 2.

- Si une ligne se trouve dans le tableau n°2 (feuille 2) et pas dans le tableau n°1 (feuille 1), alors, il faut supprimer la ligne du tableau 2.

- Si les lignes sont les mêmes, aucune action.

J'ai ensuite ajouté un code à ma sauce pour exécuter un tri (car les lignes ajoutées étaient ajoutées tout en bas du tableau, alors que je souhaite avoir les éléments dans le même ordre, question pratique).

Mes problèmes sur les tests réalisés :

1°/ : Si je vide le tableau de la feuille 2 et que j'exécute la macro avec le bouton "UPDATE", le tableau de la feuille 2 se remplit avec les éléments de la feuille 1 (jusque-là normal) sauf 2 lignes qui n'apparaîtront que si l'on relance encore une fois la macro. Ce n'est pas normal.

2°/ : Si je supprime volontairement une ligne du tableau 1 (feuille 1) et que je relance la macro, la ligne ne se supprime pas dans le tableau 2 (feuille 2).


Merci d'avance de vous pencher sur mon problème. Je sais qu'il est un peu complexe.

Bien cordialement.

8 réponses

  1. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    Bonjour

    Ci dessous une proposition de code pas encore testée

    Option Explicit
    '------------------------------------------------------------------------
    Sub mettre_a_jour()
    Dim Derlig As Integer, T_tiers, Cptr As Integer, D_tiers As Object, Concat As String, _
    T_keys_tiers, T_ligne_t
    Dim T_relance, D_relance As Object, T_keys_rel, T_ligne_r
    Dim Copie
    '--------------------------------initialisations
    Application.ScreenUpdating = False

    'mémorisation des "tiers"
    With Sheets("Grand-livre des tiers")
    Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row
    T_tiers = .Range("A3:J" & Derlig)
    Set D_tiers = CreateObject("scripting.dictionary")
    For Cptr = 1 To UBound(T_tiers)
    Concat = T_tiers(Cptr, 3) & " " & T_tiers(Cptr, 5) & " " & T_tiers(Cptr, 10)
    'création d'un dictionnaire clé : "éléments à comparer item=ligne classeur
    If Not D_tiers.exists(Concat) Then D_tiers.Add Concat, Cptr + 2
    Next
    End With

    'mémorisation des "relances"
    T_keys_tiers = D_tiers.keys
    T_ligne_t = D_tiers.items
    With Sheets("Tableau de relance")
    Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row
    T_relance = .Range("A4:J" & Derlig)
    Set D_tiers = CreateObject("scripting.dictionary")
    For Cptr = 1 To UBound(T_relance)
    Concat = T_relance(Cptr, 3) & " " & T_relance(Cptr, 5) & " " & T_relance(Cptr, 10)
    'création d'un dictionnaire clé : "éléments à comparer, ligne classeur
    If Not D_relance.exists(Concat) Then D_relance.Add Concat, Cptr + 3
    Next
    T_keys_rel = D_relance.keys
    T_ligne_r = D_relance.items
    End With

    '-----------------------------------------------Mises à jour

    ' nouveaux tiers: ajoute une ligne aux relances
    For Cptr = 0 To D_tiers.Count - 1
    If Not D_relance.exists(T_keys_tiers(Cptr)) Then
    Copie = Sheets("Grand-livre des tiers").Range(Cells(T_ligne_t(Cptr), "A"), Cells(T_ligne_t(Cptr), "J"))
    Derlig = Derlig + 1
    Sheets("Tableau de relance").Range(Cells(Derlig, "A"), Cells(Derlig, "J")) = Copie
    End If
    Next
    'relance effectuée
    For Cptr = 0 To D_relance.Count - 1
    If Not D_tiers.exists(T_keys_rel(Cptr)) Then
    Sheets("Tableau de relance").Rows(T_ligne_r(Cptr)).Delete
    End If
    Next
    MsgBox "Mises à jour effectuées"
    End Sub


    Pour m'aider:
    Pour que je puisse tester + facilement, pourais tu me dire les numéros de ligne des "nouveaux tiers" et dles "relances effectuées"
    D'avance Merci

    Michel
    1
    1. Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
       
      J'ai Variable Objet non défini lorsque j'exécute la macro sur la ligne "If Not D_relance.exists(Concat) Then" il semble que ton code soit beaucoup plus fiable que celui que j'avais précédemment...
      0
  2. f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717
     
    Bonjour,

    michel_m: les dico sont vraiment au poil pour ce genre de "tri"

    neanmoins, fichier de Kuartz corrige : https://www.cjoint.com/c/EFEnln6RnNf

    1: du au tableau "vide", ajoute un test
    2: un l+4 au lieu de l+3
    1
    1. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      bojour
      Je viens de corriger le code avec pas mal de fautes de syntaxe
      0
  3. Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
     
    Tout d'abord, merci beaucoup pour l'aide.

    Je viens de tester, j'ai "Erreur de compilation, variable non définie" et en surligné D_Relance.

    Après ne te prend pas la tête, ajoute une ligne au hasard sur le tableau 1. Et je te propose d'écrire une date dans "DATE LETTRE RAPPEL 1". Normalement, il faudrait que le code se comporte de façon à supprimer les lignes qui ne sont pas dans le tableau 1 et à rajouter les lignes en 1 et pas en 2, tout en gardant la date en face de la bonne ligne, comme auparavant dans DATE LETTRE RAPPEL 1.
    1
  4. Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
     
    Pour l'instant les tableaux sont identiques, il suffit de les modifier au hasard pour voir le comportement du code.
    1
  5. Vous n’avez pas trouvé la réponse que vous recherchez ?

    Posez votre question
  6. Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
     
    O2.Range("A4:J70").ClearContents : Pourquoi cette ligne ajoutée?

    Le but n'est pas d'avoir un tableau vide en feuille 2.

    Je m'explique, le tableau 1 va changer chaque mois, il s'agit de données en comptabilité. Le tableau 2 doit s'adapter en fonction du tableau 1. Mais des choses vont être ajoutées au tableau 2 dans "LETTRE DE RAPPEL 1" etc. Et ces choses là doivent absolument rester en face de la ligne correspondante.

    Le tableau 2 ne doit jamais être supprimé en fait.
    1
    1. f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717
       
      Re,

      Le but n'est pas d'avoir un tableau vide en feuille 2. Z'etes sur de connaitre le VBA ?? Cette ligne est en commentaire, je l'ai mise pour faire des tests tableau vide, si elle vous gene, enlevez la
      0
    2. Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
       
      D'accord OK merci. Je connais peu le VBA, mais je sais qu'il s'agissait d'un commentaire. J'avais mal compris et je croyais que les commentaires étaient en fait vos corrections.
      0
      1. f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717 > Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention  
         
        Re,

        Donc, une ligne dans tableau2 avec kakechose dans une des colonnes

        DATE LETTRE RAPPEL 1 DATE LETTRE RAPPEL 2 DATE MISE EN DEMEURE DATE POURSUITE JUDICIARE ACTIONS

        ne doit pas etre suprimee, meme si elle ne figure pas dans le tableau1
        0
  7. Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
     
    Tout marche parfaitement. Je vous remercie.
    1
  8. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    ci joint code testé avec succès
    peut-^tre jeter un oeil avant de marquer résolu ne serait ce que par politesse envers quelqu'un qui s'est cassé le... pour te montrer l'utilité d'un objet dictionary pour ce genre de problème
    http://www.cjoint.com/c/EFEp7qlLsZr
    je le mets quand m^me sans me faire trop d'illusions
    1
    1. f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717
       
      Bonjour,

      j'ai fait la meme modif (principe) que dans le fichier de Kuartz, je mets le code car probleme avec ci-joint (!!!). Modif au plus simple car pas facile avec les tests dico

      Option Explicit
      '------------------------------------------------------------------------
      Sub mettre_a_jour()
          Dim Derlig As Integer, T_tiers, Cptr As Integer, D_tiers As Object, Concat As String, _
          T_keys_tiers, T_ligne_t
          Dim T_relance, D_relance As Object, T_keys_rel, T_ligne_r
          Dim Copie
          Dim memligdep
      '--------------------------------initialisations
      Application.ScreenUpdating = False
      
          'Sheets("Tableau de relance").Range("A4:J70").ClearContents
      
      'mémorisation des "tiers"
      With Sheets("Grand-livre des tiers")
          Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row
          T_tiers = .Range("A3:J" & Derlig)
          Set D_tiers = CreateObject("scripting.dictionary")
          For Cptr = 1 To UBound(T_tiers)
              Concat = T_tiers(Cptr, 3) & " " & T_tiers(Cptr, 5) & " " & T_tiers(Cptr, 10)
              'création d'un dictionnaire clé : "éléments à comparer item=ligne classeur
              If Not D_tiers.exists(Concat) Then
                  D_tiers.Add Concat, Cptr + 2
              End If
          Next
      End With
      
      'mémorisation des "relances"
      T_keys_tiers = D_tiers.keys
      T_ligne_t = D_tiers.items
       With Sheets("Tableau de relance")
          Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row
              T_relance = .Range("A4:J" & Derlig)
              Set D_relance = CreateObject("scripting.dictionary")
              For Cptr = 1 To UBound(T_relance)
                  Concat = T_relance(Cptr, 3) & " " & T_relance(Cptr, 5) & " " & T_relance(Cptr, 10)
                  'création d'un dictionnaire clé : "éléments à comparer, ligne classeur
                  If Not D_relance.exists(Concat) Then
                      D_relance.Add Concat, Cptr + 3
                  End If
              Next
              T_keys_rel = D_relance.keys
              T_ligne_r = D_relance.items
      End With
      'mise en memoire ligne pour savoir si tableau vide (=3)
      memligdep = Derlig
      '-----------------------------------------------Mises à jour
      ' nouveaux tiers: ajoute une ligne aux relances
      For Cptr = 0 To D_tiers.Count - 1
          If memligdep <= 3 Or Not D_relance.exists(T_keys_tiers(Cptr)) Then
              With Sheets(1)
                  Copie = .Range(.Cells(T_ligne_t(Cptr), 1), .Cells(T_ligne_t(Cptr), 10))
              End With
              With Sheets(2)
                  Derlig = Derlig + 1
                  .Range(.Cells(Derlig, 1), .Cells(Derlig, 10)) = Copie
              End With
          End If
      Next
      'relance effectuée
      For Cptr = 0 To D_relance.Count - 1
          If memligdep > 3 And Not D_tiers.exists(T_keys_rel(Cptr)) Then
              Sheets("Tableau de relance").Rows(T_ligne_r(Cptr)).Delete
          End If
      Next
          Set D_relance = Nothing
          Set D_tiers = Nothing
      Application.ScreenUpdating = True
          MsgBox "Mises à jour effectuées"
          
      End Sub
      </code>


      Si tableau Tableau de relance vide, la ca coince et la ligne 4 fraichement ecrite se trouve delete car dans le dico D_relance il y a les cellules de la ligne 3

      With Sheets("Tableau de relance")
      Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row
      T_relance = .Range("A4:J" & Derlig)

      et ici sans le test si non vide

      For Cptr = 0 To D_relance.Count - 1
      If memligdep > 3 And Not D_tiers.exists(T_keys_rel(Cptr)) Then

      ca efface la ligne
      0
  9. Kuartz Messages postés 852 Date d'inscription   Statut Membre Dernière intervention   65
     
    Bonjour,

    Je ne connais pas du tout le principe d'un "dictionnary". Je vais tenter de déchiffrer le code.

    Pour information, mon problème étant résolu et le code marchant parfaitement, j'ai mis le sujet en résolu. Je te prie de m'excuser si j'ai pu te froisser.

    Je te remercie vraiment beaucoup d'avoir passé du temps sur mon problème et d'avoir même sorti un code à ta sauce pour m'arranger. Je vais me pencher dessus pour essayer de le comprendre (je n'ai que des bases de VBA). En tout cas, après l'avoir testé également, il marche absolument parfaitement.

    Merci encore.
    1
    1. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      tu m'as pas froissé mais déçu et découragé d'essayer d'apporter de l'aide
      surtout que je t'avais écrit que je testerai + tard
      0