Comparaison de 2 tableaux avec modifications

Résolu/Fermé
Kuartz Messages postés 850 Date d'inscription vendredi 13 février 2015 Statut Membre Dernière intervention 15 février 2019 - Modifié par Kuartz le 30/06/2015 à 11:25
michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 - 1 juil. 2015 à 10:53
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.
A voir également:

8 réponses

michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 303
Modifié par michel_m le 30/06/2015 à 15:17
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
Kuartz Messages postés 850 Date d'inscription vendredi 13 février 2015 Statut Membre Dernière intervention 15 février 2019 61
30 juin 2015 à 16:28
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
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 702
Modifié par f894009 le 30/06/2015 à 15:16
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
michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 303
30 juin 2015 à 15:20
bojour
Je viens de corriger le code avec pas mal de fautes de syntaxe
0
Kuartz Messages postés 850 Date d'inscription vendredi 13 février 2015 Statut Membre Dernière intervention 15 février 2019 61
Modifié par Kuartz le 30/06/2015 à 15:25
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
Kuartz Messages postés 850 Date d'inscription vendredi 13 février 2015 Statut Membre Dernière intervention 15 février 2019 61
30 juin 2015 à 15:25
Pour l'instant les tableaux sont identiques, il suffit de les modifier au hasard pour voir le comportement du code.
1

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Kuartz Messages postés 850 Date d'inscription vendredi 13 février 2015 Statut Membre Dernière intervention 15 février 2019 61
30 juin 2015 à 15:59
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
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 702
30 juin 2015 à 16:05
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
Kuartz Messages postés 850 Date d'inscription vendredi 13 février 2015 Statut Membre Dernière intervention 15 février 2019 61
Modifié par Kuartz le 30/06/2015 à 16:30
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
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 702 > Kuartz Messages postés 850 Date d'inscription vendredi 13 février 2015 Statut Membre Dernière intervention 15 février 2019
30 juin 2015 à 17:46
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
Kuartz Messages postés 850 Date d'inscription vendredi 13 février 2015 Statut Membre Dernière intervention 15 février 2019 61
30 juin 2015 à 17:53
Tout marche parfaitement. Je vous remercie.
1
michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 303
30 juin 2015 à 18:03
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
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 702
Modifié par f894009 le 1/07/2015 à 08:59
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
Kuartz Messages postés 850 Date d'inscription vendredi 13 février 2015 Statut Membre Dernière intervention 15 février 2019 61
1 juil. 2015 à 09:37
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
michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 303
1 juil. 2015 à 10:53
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