Comparer 2 tableaux lignes par lignes

**jomassilia** · 23/03/2013, 22h04

Bonjour a tous,

je suis débutant en vba et voilà 2 jours que je cherche une solution sur le web pour mon problème.

J'ai un tableau 1 sur la feuille 1 avec 15 colonnes et x lignes.
j'ai un 2eme tableau sur la feuille 2 qui n'est en fait qu'une mise à jour du tableau 1 sur la feuille 1 donc avec des lignes supplémentaire.
La dimension des 2 tableaux n'est donc pas fixe (sauf le nombre de colonne).
Plusieurs cellules de 2 lignes peuvent etre identique. Il faut donc comparer les ligne entière.

Mon but est de comparer ligne par ligne les 2 tableaux et de copier sur le tableau 1 de la feuille 1 les nouvelles lignes du tableau 2 de la feuille 2 et de les identifier en police rouge sur les 2 feuilles.

SVP AIDEZ MOI

A l'instant t je n'ai réussi à rien faire. Trop de variable, tableaux dynamique...

voila ce que j'ai essayé de faire, dans le but d'identifier les lignes en feuille 2 déjà présentes en feuille 1 et ainsi dans un 2ème temps d'identifier plus simplement les nouvelles lignes en feuille 2

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub essai()
 
Dim i As Integer
Dim j As Integer
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
Set ws3 = Worksheets(3)
Dim DernLigne1 As Long
DernLigne1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
Dim DernLigne2 As Long
DernLigne2 = ws1.Range("A" & Rows.Count).End(xlUp).Row
 
 
For i = 2 To DernLigne2
    For j = 2 To DernLigne1
        If ws2.Range("A" & i, "D" & i) = ws1.Range("A" & j, "D" & j) Then
        Sheets("feuil2").Range("E" & i) = "Présent"
        End If
    Next j
Next i
 
End Sub

J'obtient une erreur de compilation.

**Vadorblanc** · 23/03/2013, 22h46

Bonjour jomassilia
Un code qui compare les lignes de feuille 1 et feuille 2 sur différence des colonnes ABEFH que tu peux facilement adapter sur tes 15 colonnes, et les différences trouvées sont mises dans une nouvelle feuille
Cordialement

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
92
93
94
95
96
97
98
99
100
101
Sub Compare_Col_ABEFH_sur_Sheet1_et2()
 
 
Dim wbk As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim LastLig1 As Long, LastLig2 As Long, i As Long, k As Long
Dim c As Range, v As Range
 
Application.ScreenUpdating = False
    Set wbk = ThisWorkbook
    Set ws1 = wbk.Worksheets(1)
    Set ws2 = wbk.Worksheets(2)
    LastLig1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    LastLig2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
 
    Set ws3 = wbk.Worksheets.Add(After:=wbk.Sheets(wbk.Worksheets.Count))
 
       '................................
    For i = 1 To LastLig2
        Set c = ws1.Range("A1:A" & LastLig1).Find(ws2.Range("A" & i).Value, lookat:=xlWhole)
        If c Is Nothing Then
        Set v = ws3.Columns(1).Find(ws2.Range("A" & i).Value, lookat:=xlWhole)
        If v Is Nothing Then
            k = k + 1
            ws2.Range("A" & i & ":S" & i).Copy ws3.Range("A" & k)
            End If
        End If
        Set v = Nothing
    Next i
    '................................
    For i = 1 To LastLig2
        Set c = ws1.Range("B1:B" & LastLig1).Find(ws2.Range("B" & i).Value, lookat:=xlWhole)
        If c Is Nothing Then
        Set v = ws3.Columns(1).Find(ws2.Range("B" & i).Value, lookat:=xlWhole)
        If v Is Nothing Then
            k = k + 1
            ws2.Range("A" & i & ":S" & i).Copy ws3.Range("A" & k)
            End If
        End If
        Set v = Nothing
    Next i
    '...................................
    For i = 1 To LastLig2
        Set c = ws1.Range("D1:D" & LastLig1).Find(ws2.Range("D" & i).Value, lookat:=xlWhole)
        If c Is Nothing Then
        Set v = ws3.Columns(1).Find(ws2.Range("D" & i).Value, lookat:=xlWhole)
        If v Is Nothing Then
            k = k + 1
            ws2.Range("A" & i & ":S" & i).Copy ws3.Range("A" & k)
            End If
        End If
        Set v = Nothing
    Next i
    '...................................
 
For i = 1 To LastLig2
        Set c = ws1.Range("E1:E" & LastLig1).Find(ws2.Range("E" & i).Value, lookat:=xlWhole)
        If c Is Nothing Then
        Set v = ws3.Columns(1).Find(ws2.Range("E" & i).Value, lookat:=xlWhole)
        If v Is Nothing Then
            k = k + 1
            ws2.Range("A" & i & ":S" & i).Copy ws3.Range("A" & k)
            End If
        End If
        Set v = Nothing
    Next i
    '...................................
 
For i = 1 To LastLig2
        Set c = ws1.Range("F1:F" & LastLig1).Find(ws2.Range("F" & i).Value, lookat:=xlWhole)
        If c Is Nothing Then
        Set v = ws3.Columns(1).Find(ws2.Range("F" & i).Value, lookat:=xlWhole)
        If v Is Nothing Then
            k = k + 1
            ws2.Range("A" & i & ":S" & i).Copy ws3.Range("A" & k)
            End If
        End If
        Set v = Nothing
    Next i
 
    '...................................
 
For i = 1 To LastLig2
        Set c = ws1.Range("H1:H" & LastLig1).Find(ws2.Range("H" & i).Value, lookat:=xlWhole)
        If c Is Nothing Then
        Set v = ws3.Columns(1).Find(ws2.Range("H" & i).Value, lookat:=xlWhole)
        If v Is Nothing Then
            k = k + 1
            ws2.Range("A" & i & ":S" & i).Copy ws3.Range("A" & k)
            End If
        End If
        Set v = Nothing
    Next i
    '...................................
 
    Set c = Nothing
    Set ws3 = Nothing
    Set ws2 = Nothing
    Set ws1 = Nothing
    Set wbk = Nothing
End Sub

**jomassilia** · 23/03/2013, 23h36

Salut Vadorblanc. Merci pour ta réponse.
Quand je vois ton code je vois que je partais de très loin.

Je viens de le tester sur un fichier test et ça fonctionne à ceci près qu'il me fait des lignes en doublon sur la 3eme feuille a la copie.

Vois tu d'où vient le problème ?

Les nouvelles lignes en feuilles 2 ne sont pas à la fin du tableau mais insérées n'importe où ds le tableau 2. Et la ligne 1 est fixe puisqu'il s'agit des titres de colonne.

Merci d'avance.

**gFZT82** · 24/03/2013, 00h33

Bonjour,

Tu peux peut-être te contenter de faire comme cela

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Sub essai()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim Plage2 As Range
    Set Ws1 = Worksheets(1)
    Set Ws2 = Worksheets(2)
    Set Plage2 = Ws2.Range("A2:D" & Ws2.Range("A" & Rows.Count).End(xlUp).Row)
    Plage2.Font.ColorIndex = 3
    Plage2.Copy Ws1.Range("A" & Ws1.Range("A" & Rows.Count).End(xlUp).Row).Offset(1, 0)
    Plage2.Font.ColorIndex = 1
    Ws1.Range("A1:D" & Ws1.Range("A" & Rows.Count).End(xlUp).Row).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
End Sub

Cordialement.