comparaison de deux tableaux sur VBA

Version imprimable

27/11/2020, 18h05
kito007

1 pièce(s) jointe(s)

comparaison de deux tableaux sur VBA

slt tout le monde,

voici mon problème : j'ai réalisé deux macro , une pour supprimer les doublons , et une autre pour comparer deux tableaux , alors le problème qui se pose c'est que je n'arrive pas a finir mon programme sur vba , je suis vraiment bloquer!

ci-joint le fichier sur lequel j'ai programmé avec une explication détaillé dans la feuille "méthode"

je vous remercie d'avance pour votre aide :oops:

bonne soirée
27/11/2020, 18h25
mfoxy

Bonsoir,

Tres peu de membre ouvre les pièces jointes pour des raisons de sécurité.
Il voudrait mieux que vous indiquez ici votre code entre balise.

Au vu de votre sujet, je dirais que Power query pourr8faire le job et ce sans une ligne de code.
Vous trouverez dans le lien ci-dessous, les différentes jointures possible dans Power query.

https://www.developpez.net/forums/bl...res-possibles/

Bav,

Bonjour,
merci mfoxy pour votre réponse , mais j'ai essayé power query et ca marche pas vraiment ,

je vais détailler un peu ma problématique :

les données d'entrée sont deux tableaux dans deux feuille Excel ( test 1 et test 2 ):

test1:

id nbr Qte

A 10 23

B 34 53

C 45 6

H 14 73

H 14 73

H 14 73

H 14 73

Z 34 73

w 14 73

test 2 :

id nbr Qte

A 10 23

B 12 53

C 14 73

D 14 73

G 15 73

H 14 73

H 14 73

H 14 73

H 14 73

- les étapes de mon programme:

1. supprimer les doublons dans le tableau de la feuille "test 2 "
2. comparer les lignes entre le tableau de la feuille "test2" et "test1":
- si le id dans le test1 n'existe pas dans le test2 donc : on rajoute cette ligne dans test2 et on la remplit en couleur rouge
- si id dans le test2 n'existe pas dans le test1 donc : on met cette ligne dans test2 en couleur verte
- si id dans le test1 existe dans le test2 mais les autre colonne de la ligne sont différente donc : on change la couleur de la ligne en test2 en orange, et on met la valeur qui était chang en rouge gras
- si les lignes dans les deux feuille sont identique , on fait rien ! => on les gardes dans test2 avec leur couleur d'origine

solution 1/ voici le programme que j'ai testé sur vba :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 Sub delete_double() Dim Plage As Range, Cell As Range Dim Un As New Collection Dim Tableau() As Integer Dim x As Integer 'Définit la plage de cellules pour la recherche de doublons Set Plage = Worksheets("test2").Range("A1:A30") On Error Resume Next 'Boucle sur les cellules de la plage cible For Each Cell In Plage 'Création d'une collection de données uniques (sans doublons) Un.Add Cell, CStr(Cell) 'Une erreur survient si l'élément existe dans la collection. 'La procédure enregistre le numéro de ligne correspondant dans un tableau. If Err.Number <> 0 Then x = x + 1 ReDim Preserve Tableau(1 To x) Tableau(x) = Cell.Row Err.Clear End If Next Cell On Error GoTo 0 'On sort si aucun doublon n'a été trouvé. If x = 0 Then Exit Sub 'Fige l'écran pendant la suppression des lignes Application.ScreenUpdating = False 'Boucle sur le tableau pour supprimer les lignes contenant des doublons. For x = UBound(Tableau) To LBound(Tableau) Step -1 Worksheets("test2").Rows(Tableau(x)).EntireRow.Delete Next x Application.ScreenUpdating = True End Sub
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 Sub add_cells() Dim FL1 As Worksheet, FL2 As Worksheet Dim Cel As Range, C As Range Dim LigneAjout As Long Set FL1 = Worksheets("test1") Set FL2 = Worksheets("test2") For Each Cel In FL1.Range("A2:A" & FL1.Range("A" & Rows.Count).End(xlUp).Row) Set C = FL2.Columns(1).Find(Cel, , xlValues, xlWhole) LigneAjout = FL2.Range("A" & Rows.Count).End(xlUp).Row + 1 If Not C Is Nothing Then Cel.Resize(, 3).Copy FL2.Range("A" & C.Row) Else Cel.Resize(, 3).Copy FL2.Range("A" & LigneAjout) FL2.Range("A" & LigneAjout).Interior.Color = RGB(224, 128, 0) LigneAjout = LigneAjout + 1 End If Next Cel Set C = Nothing: Set FL1 = Nothing: Set FL2 = Nothing End Sub
2 -ème solution / sur power query:

j'ai combiner les deux tableau et puis j'ai utilisé une colonne conditionnelle, mais c'était pas ce que je voulais avoir comme résultat!

le tableau ci-dessus est juste un exemple, mais les données que je dois traiter sont énorme : 2000 ligne et 150 colonnes !

j'ai penser aussi a utiliser python si c'est le plus facile a gérer tout ca !

j'ai vraiment besoin d'aide pour avancer!

id	nbr	Qte
A	10	23
B	34	53
C	45	6
H	14	73
H	14	73
H	14	73
H	14	73
Z	34	73
w	14	73

id	nbr	Qte
A	10	23
B	12	53
C	14	73
D	14	73
G	15	73
H	14	73
H	14	73
H	14	73
H	14	73

1 pièce(s) jointe(s)

Bonjour
Peut être une début de piste

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
Sub test()
Application.ScreenUpdating = False
Dim f1 As Worksheet
Dim f2 As Worksheet
Dim f3 As Worksheet
Set f1 = Sheets("test1")
Set f2 = Sheets("test2")
Set f3 = Sheets("test3")
 
'****************copier tableau test1 dans l'onglet test2 sans doublons
f1.Range("A1:C" & f1.Cells(Rows.Count, 1).End(xlUp).Row).Copy f2.Range("A1")
 f2.Range("A1:C" & Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=1
 
f2.Columns("D:D").ClearContents
Dim TblBD1
Dim TblBD2
Dim i As Integer
Dim j As Integer
Dim Lig As Long
Dim Identique As Boolean
Dim Entest3 As Boolean
Dim Entest2 As Boolean
 
 
TblBD1 = f2.Range("A2:C" & f2.Range("A" & Rows.Count).End(xlUp).Row)
TblBD2 = f3.Range("A2:C" & f3.Range("A" & Rows.Count).End(xlUp).Row)
For i = LBound(TblBD1) To UBound(TblBD1)
 Lig = i + 1
    '*************************************Article identique *********************************
    For j = LBound(TblBD2) To UBound(TblBD2)
        If TblBD2(j, 1) = TblBD1(i, 1) And TblBD2(j, 2) = TblBD1(i, 2) And TblBD2(j, 3) = TblBD1(i, 3) Then
         f2.Cells(Lig, 4) = "Article identique sur les deux tableaux"
        End If
        If TblBD2(j, 1) = TblBD1(i, 1) And TblBD2(j, 2) <> TblBD1(i, 2) And TblBD2(j, 3) = TblBD1(i, 3) Then
         f2.Cells(Lig, 4) = "Article existe mais problème de nombre"
        End If
        If TblBD2(j, 1) = TblBD1(i, 1) And TblBD2(j, 2) = TblBD1(i, 2) And TblBD2(j, 3) <> TblBD1(i, 3) Then
         f2.Cells(Lig, 4) = "Article existe mais problème de quantité"
        End If
        If TblBD2(j, 1) = TblBD1(i, 1) And TblBD2(j, 2) <> TblBD1(i, 2) And TblBD2(j, 3) <> TblBD1(i, 3) Then
         f2.Cells(Lig, 4) = "Article existe mais problème de nombre et de quantité"
        End If
 
    Next j
Next i
MsgBox ("Controle effectué")
  f2.Select
Application.ScreenUpdating = True
 
End Sub

Merci bcp BENNASR pour votre aide,

pour les deux première macros (copier et supprimer les doublons) ca marche très bien, par contre pour la deuxième partie je pense j'étais pas claire ,
alors je reformule ma question :

j'ai deux tableau test2 et test3 :

test2:

id nbr Qte

A 10 13

B 15 53

D 22 40

C 45 6

H 14 73

test 3 :

id nbr Qte

A 10 23

B 34 53

C 45 6

H 14 73

Z 34 73

w 14 73

ce que j'aimerais avoir dans test2:

- toutes les modifications de cellules
- les lignes ajoutées
- les lignes supprimées
- les lignes qui sont les mêmes dans les deux tableaux

donc j'aurais à la fin un truc pareil :

id nbr Qte

A 10 13

B 15 53

D 22 40

C 45 6

H 14 73

Z 34 73

w 14 73

les lignes en jaune : sont été modifier par rapport au ligne qui existent dans test3 (et on met en gras les valeurs qui ont modifié)
les lignes en vert : sont les nouvelles lignes (elle n'existent pas dans test3)
les lignes en rouge : sont les lignes qui ont été supprimer (elle se trouvent dans le test3)
les lignes couleur neutre : c'est les lignes qui existent dans les deux fichier et qui ont été pas modifier

voila le programme , mais il n'est pas complet , ce qu'il manque est: c'est la partie des lignes modifier et non modifier !
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 Sub project_nom() 'test1 : plan gamme m-1 'test2 : plan gamme update Dim FL1 As Worksheet Dim FL2 As Worksheet Dim cel As Range Dim c As Range Dim LigneAjout As Long Set FL1 = Worksheets("test1") Set FL2 = Worksheets("test2") For Each cel In FL1.Range("A2:A" & FL1.Range("A" & Rows.Count).End(xlUp).Row) Set c = FL2.Columns(1).Find(cel, , xlValues, xlWhole) LigneAjout = FL2.Range("A" & Rows.Count).End(xlUp).Row + 1 If Not c Is Nothing Then FL2.Range("A" & cel.Row).Interior.Color = RGB(255, 255, 0) Else ' projet suprimer en rouge cel.Resize(, 3).Copy FL2.Range("A" & LigneAjout) FL2.Range("A" & LigneAjout).Interior.Color = RGB(192, 0, 0) LigneAjout = LigneAjout + 1 End If Next cel 'nouveau projet en vert For Each cel In FL2.Range("A2:A" & FL2.Range("A" & Rows.Count).End(xlUp).Row) Set c = FL1.Columns(1).Find(cel, , xlValues, xlWhole) If Not c Is Nothing Then Else FL2.Range("A" & cel.Row).Interior.Color = RGB(160, 255, 0) End If Next cel Set c = Nothing: Set FL1 = Nothing: Set FL2 = Nothing End Sub
merci d'avance pour votre aide :bug:

id	nbr	Qte
A	10	13
B	15	53
D	22	40
C	45	6
H	14	73

id	nbr	Qte
A	10	23
B	34	53
C	45	6
H	14	73
Z	34	73
w	14	73

id	nbr	Qte
A	10	13
B	15	53
D	22	40
C	45	6
H	14	73
Z	34	73
w	14	73

1 pièce(s) jointe(s)

bonjour
pas certain d'avoir compris la demande
tester ça et puis on verra

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
Sub test()
Application.ScreenUpdating = False
Dim f1 As Worksheet
Dim f2 As Worksheet
Dim f3 As Worksheet
Set f1 = Sheets("test1")
Set f2 = Sheets("test2")
Set f3 = Sheets("test3")
 
'****************copier tableau test1 dans l'onglet test2 sans doublons
f1.Range("A1:C" & f1.Cells(Rows.Count, 1).End(xlUp).Row).Copy f2.Range("A1")
 f2.Range("A1:C" & Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=1
f2.Cells.Interior.Pattern = xlNone
f2.Cells.Borders.LineStyle = xlLineStyleNone
 
 
Dim Champ1 As Range
Dim Champ2 As Range
Dim C As Range
Dim X As Range
 
Set Champ1 = f2.Range("A2:A" & f2.Range("A" & Rows.Count).End(xlUp).Row)
Set Champ2 = f3.Range("A2:A" & f3.Range("A" & Rows.Count).End(xlUp).Row)
 
For Each X In Champ2
 
    For Each C In Champ1
        If C.Value = X.Value And f2.Cells(C.Row, 2) <> f3.Cells(X.Row, 2) And f2.Cells(C.Row, 3) = f3.Cells(X.Row, 3) Then
         f2.Cells(C.Row, 2) = f3.Cells(X.Row, 2)
         f2.Cells(C.Row, 2).Interior.Color = vbRed
         f2.Cells(C.Row, 2).Font.Bold = True
         f2.Cells(2, "E").Interior.Color = vbRed
         f2.Cells(2, "F") = "Article existe mais problème de valeur"
        End If
         If C.Value = X.Value And f2.Cells(C.Row, 2) = f3.Cells(X.Row, 2) And f2.Cells(C.Row, 3) <> f3.Cells(X.Row, 3) Then
 
         f2.Cells(C.Row, 3) = f3.Cells(X.Row, 3)
         f2.Cells(C.Row, 3).Interior.Color = vbRed
         f2.Cells(C.Row, 3).Font.Bold = True
         f2.Cells(2, "E").Interior.Color = vbRed
         f2.Cells(2, "F") = "Article existe mais problème de valeur"
        End If
 
         If C.Value = X.Value And f2.Cells(C.Row, 2) <> f3.Cells(X.Row, 2) And f2.Cells(C.Row, 3) <> f3.Cells(X.Row, 3) Then
         f2.Cells(C.Row, 2) = f3.Cells(X.Row, 2)
         f2.Cells(C.Row, 3) = f3.Cells(X.Row, 3)
         f2.Cells(C.Row, 2).Interior.Color = vbRed
         f2.Cells(C.Row, 2).Font.Bold = True
         f2.Cells(C.Row, 3).Interior.Color = vbRed
         f2.Cells(C.Row, 3).Font.Bold = True
         f2.Cells(2, "E").Interior.Color = vbRed
         f2.Cells(2, "F") = "Article existe mais problème de valeur"
        End If
 
    Next C
Next X
 
Dim Cel As Range
 For Each Cel In Champ1
   P = WorksheetFunction.CountIf(Champ2, Cel.Value)
   If P = 0 Then
    Cel.Interior.Color = vbGreen
    f2.Cells(Cel.Row, 2).Interior.Color = vbGreen
    f2.Cells(Cel.Row, 3).Interior.Color = vbGreen
    f2.Cells(3, "E").Interior.Color = vbGreen
    f2.Cells(3, "F") = "Article inexistant en test3"
   End If
   Next Cel
 
 
 For Each Cel In Champ2
   M = WorksheetFunction.CountIf(Champ1, Cel.Value)
   If M = 0 Then
   dernligne = f2.Cells(Rows.Count, 1).End(xlUp).Row + 1
    f2.Cells(dernligne, 1) = f3.Cells(Cel.Row, 1)
    f2.Cells(dernligne, 2) = f3.Cells(Cel.Row, 2)
    f2.Cells(dernligne, 3) = f3.Cells(Cel.Row, 3)
     f2.Cells(dernligne, 1).Interior.Color = vbYellow
     f2.Cells(dernligne, 2).Interior.Color = vbYellow
     f2.Cells(dernligne, 3).Interior.Color = vbYellow
     f2.Cells(4, "E").Interior.Color = vbYellow
    f2.Cells(4, "F") = "Article inexistant en test2"
 
   End If
   Next Cel
 f2.Range("A1:C" & dernligne).Borders.LineStyle = xlContinuous
MsgBox ("Controle effectué")
  f2.Select
Application.ScreenUpdating = True
 
End Sub

02/12/2020, 16h23
kito007

oui c'est excitement ca, super! merci bcp ,

j'ai une dernière chose, mon tableau d'origine contient 140 colonnes avec 2000 ligne , dans ce programme vous avez comparez colonne par colonne mais par contre je pourrez pas faire ca , est ce que il y a un moyen pour comparer le x et c comme vous avez fait et puis de comparer les valeurs dans les colonnes de E:H et de M: R par Example:

If C.Value = X.Value And (E:H).....etc

merci bcp pour votre aide !

n'est pas claire pour moi
cette partie pour définir les champs à comparer
vous pouvez les changer comme vous voulez
Code:

1 2 Set Champ1 = f2.Range("A2:A" & f2.Range("A" & Rows.Count).End(xlUp).Row) Set Champ2 = f3.Range("A2:A" & f3.Range("A" & Rows.Count).End(xlUp).Row)

je m'excuse , j'ai mal exprimé je vais reformuler ma question.
les tableaux d'origines sont comme suite :

test 2 :

id nbr Qte mar jer fil qm jr ........

A 10 13 17 .....

B 15 53 14 .....

D 22 40 ......

C 45 6

H 14 73

F .....

........

test3:

id nbr Qte mar jer fil qm jr ........

A 10 23 18

B 34 53 20 .....

C 45 6

H 14 73

Z 34 73

w 14 73

le résultat souhaiter est le même que celui que vous avez fait dans le programme précèdent mais ce qui va être changer c'est cette partie ci-dessous :
Code:

1 2 3 4 5 6 If C.Value = X.Value And f2.Cells(C.Row, 2) <> f3.Cells(X.Row, 2) And f2.Cells(C.Row, 3) = f3.Cells(X.Row, 3) Then f2.Cells(C.Row, 2) = f3.Cells(X.Row, 2) f2.Cells(C.Row, 2).Interior.Color = vbRed f2.Cells(C.Row, 2).Font.Bold = True f2.Cells(2, "E").Interior.Color = vbRed f2.Cells(2, "F") = "Article existe mais problème de valeur"
comment je vais me procéder pour comparer plusieurs colonnes pas seulement la colonne 2 et 3 ?

pas sure d'avoir bien compris
à tester avec prudence

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
Sub test()
Application.ScreenUpdating = False
Dim f1 As Worksheet
Dim f2 As Worksheet
Dim f3 As Worksheet
Dim derlig As Long
Dim dercol As Long
Dim derlig2 As Long
Dim col As Long
Set f1 = Sheets("test1")
Set f2 = Sheets("test2")
Set f3 = Sheets("test3")
 
'****************copier tableau test1 dans l'onglet test2 sans doublons
 
derlig = f1.Cells(Rows.Count, 1).End(xlUp).Row
dercol = f1.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
f2.Cells.ClearContents
f1.Range(f1.Cells(1, 1), f1.Cells(derlig, dercol)).Copy f2.Range("A1")
f2.Range(f2.Cells(1, 1), f2.Cells(derlig, dercol)).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=1
f2.Cells.Interior.Pattern = xlNone
f2.Cells.Borders.LineStyle = xlLineStyleNone
Dim Champ1 As Range
Dim Champ2 As Range
Dim C As Range
Dim X As Range
 
Set Champ1 = f2.Range("A2:A" & f2.Range("A" & Rows.Count).End(xlUp).Row)
Set Champ2 = f3.Range("A2:A" & f3.Range("A" & Rows.Count).End(xlUp).Row)
For Each X In Champ2
    For Each C In Champ1
     For col = 1 To dercol
        If C.Value = X.Value And f2.Cells(C.Row, col) <> f3.Cells(X.Row, col) Then
         f2.Cells(C.Row, col) = f3.Cells(X.Row, col)
         f2.Cells(C.Row, col).Interior.Color = vbRed
         f2.Cells(C.Row, col).Font.Bold = True
        End If
        Next col
    Next C
Next X
Dim Cel As Range
 For Each Cel In Champ1
   P = WorksheetFunction.CountIf(Champ2, Cel.Value)
   If P = 0 Then
    Cel.Interior.Color = vbGreen
    For col = 1 To dercol
    f2.Cells(Cel.Row, col).Interior.Color = vbGreen
    f2.Cells(Cel.Row, col).Interior.Color = vbGreen
    Next col
   End If
   Next Cel
 For Each Cel In Champ2
   M = WorksheetFunction.CountIf(Champ1, Cel.Value)
   If M = 0 Then
   dernligne = f2.Cells(Rows.Count, 1).End(xlUp).Row + 1
   For col = 1 To dercol
   f2.Cells(dernligne, col) = f3.Cells(Cel.Row, col)
   f2.Cells(dernligne, col).Interior.Color = vbYellow
   Next col
   End If
   Next Cel
 
MsgBox ("Controle effectué")
  f2.Select
Application.ScreenUpdating = True
 
End Sub

04/12/2020, 13h23
kito007

oui c'est exactement ca que je voulais avoir , merci bcp!

l'exécution du programme prend un peut du temps , mais c'est normale j'ai plusieurs lignes et colonnes a traiter ,

mais ca fonction!

merci bcp vous m'avez sauvez :P