VBA - Afficher le résultat d'une requête dans une nouvelle feuille

**Mia30** · 25/04/2022, 11h05

Bonjour à tous,

j'ai des valeurs sur 2 feuilles d'un même fichier Excel (une feuille nommée f1 et l'autre f2) et je dois les comparer entre elles pour déterminer si les valeurs présentent sur les 2 feuilles sont identiques ou non. J'ai commencé à écrire un programme en VBA pour colorer en vert toutes les cellules identiques dans les deux feuilles. Mais maintenant je voudrais afficher les valeurs non identiques dans une nouvelle feuille, afin de mieux voir les valeurs différentes.

Si vous avez des idées je suis preneuse.

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
Sub test()
 
Dim numero As Integer
Dim ColSyn As Integer
 
numero = 1
ColSyn = 1
 
For RowSyn = 1 To 1500
                For ligne = 1 To Sheets("f2").Cells(Rows.Count, 1).End(xlUp).Row
                    If "*" & Sheets("f1").Cells(RowSyn, ColSyn).Value & "*" Like "*" & Sheets("f2").Cells(ligne, 1).Value & "*" Then 'compare les colonnes pour voir si ils sont identiques
                        If "*" & Sheets("f1").Cells(RowSyn, ColSyn + 1).Value & "*" Like "*" & Sheets("f2").Cells(ligne, 2).Value & "*" Then
 
                                Sheets("f1").Cells(RowSyn + Rowx, ColSyn + Rowy).Interior.Color = RGB(0, 220, 0)
                                Sheets("f1").Cells(RowSyn + Rowx, ColSyn + Rowy + 1).Interior.Color = RGB(0, 220, 0)
                                Sheets("f2").Cells(ligne, 1).Interior.Color = RGB(0, 220, 0)
                                Sheets("f2").Cells(ligne, 2).Interior.Color = RGB(0, 220, 0)
 
 
                        End If
                    End If
                Next
            'End Ifexc
 
        'Next
Next
 
End Sub

Merci à vous d'avance.

**BENNASR** · 25/04/2022, 12h45

bonjour
Pensez a PowerQuery c'est simple et sans VBA et en deux clics
si non
tester ce bricolage

:

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
102
Sub testtt()
Application.ScreenUpdating = False
Dim f1 As Worksheet
Dim f2 As Worksheet
Dim f3 As Worksheet
Set f1 = Sheets("f1")
Set f2 = Sheets("f2")
Set f3 = Sheets("Résultat")
Dim TblBD1
Dim TblBD2
Dim i As Integer
Dim j As Integer
Dim Lig As Long
Dim Identique As Boolean
Dim ProbQuantite As Boolean
Dim inexistantF2 As Boolean
Dim inexistantF1 As Boolean
 
f3.Cells.ClearContents
f3.Cells(1, 1) = f1.Cells(1, 1)
f3.Cells(1, 2) = f1.Cells(1, 2)
f3.Cells(1, 3) = "Remarques"
 
TblBD1 = f1.Range("A2:B" & f1.Range("A" & Rows.Count).End(xlUp).Row)
TblBD2 = f2.Range("A2:B" & f2.Range("A" & Rows.Count).End(xlUp).Row)
Lig = 2
For i = LBound(TblBD1) To UBound(TblBD1)
    Identique = False
    ProbQuantite = False
    inexistantF2 = False
    inexistantF1 = False
    '*************************************Article identique *********************************
    For j = LBound(TblBD2) To UBound(TblBD2)
        If TblBD2(j, 1) = TblBD1(i, 1) And TblBD2(j, 2) = TblBD1(i, 2) Then
            Identique = True
            Exit For
        End If
    Next j
 
    If Identique = True Then
        With f3
            .Cells(Lig, 1) = TblBD2(j, 1)
            .Cells(Lig, 2) = TblBD2(j, 2)
            .Cells(Lig, 3) = "Article identique sur les deux tableaux"
        End With
        Lig = Lig + 1
    End If
 
    '*************************************Problème Quantité  *********************************
    For j = LBound(TblBD2) To UBound(TblBD2)
        If TblBD2(j, 1) = TblBD1(i, 1) And TblBD2(j, 2) <> TblBD1(i, 2) Then
            ProbQuantite = True
            Exit For
        End If
    Next j
 
    If ProbQuantite = True Then
        With f3
            .Cells(Lig, 1) = TblBD2(j, 1)
            .Cells(Lig, 2) = TblBD2(j, 2)
            .Cells(Lig, 3) = "Article existant mais problème de quantité"
        End With
        Lig = Lig + 1
    End If
 
    Next i
    '*************************************Existe en F1 et non pas en F2 *********************************
 
      Dim plage1 As Range
      Dim plage2 As Range
      Dim Cel As Range
      Dim dernligne As Long
   Set plage1 = f1.Range("A2:A" & f1.Range("A" & Rows.Count).End(xlUp).Row)
   Set plage2 = f2.Range("A2:A" & f2.Range("A" & Rows.Count).End(xlUp).Row)
 
   For Each Cel In plage1
   P = WorksheetFunction.CountIf(plage2, Cel.Value)
   If P = 0 Then
   dernligne = f3.Cells(Rows.Count, 1).End(xlUp).Row + 1
            f3.Cells(dernligne, 1) = f1.Cells(Cel.Row, 1)
            f3.Cells(dernligne, 2) = f1.Cells(Cel.Row, 2)
            f3.Cells(dernligne, 3) = "Article existe en F1 et non en F2"
   End If
   Next Cel
 '*************************************Existe en F2 et non pas en F1 *********************************
 
  For Each Cel In plage2
   C = WorksheetFunction.CountIf(plage1, Cel.Value)
   If C = 0 Then
   dernligne = f3.Cells(Rows.Count, 1).End(xlUp).Row + 1
            f3.Cells(dernligne, 1) = f2.Cells(Cel.Row, 1)
            f3.Cells(dernligne, 2) = f2.Cells(Cel.Row, 2)
            f3.Cells(dernligne, 3) = "Article existe en F2 et non en F1"
   End If
   Next Cel
 
MsgBox ("Controle effectué")
f3.Select
 
Application.ScreenUpdating = True
f3.Select
End Sub

**ChristianBosch** · 25/04/2022, 13h34

Bonjour Mia,

Je pense qu'il serait deja bien mieux d'utiliser des tableaux structurés afon de bénéficier des références de ceux ci ainsi que du mappage XML qui rends les manipulations bien plus efficaces.

Si tu as deux tableaux a comparer se trouvants dans deux feuilles cela donnerait ceci pour colorer les valeurs non identiques :

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
Sub compare()
Dim MyTab1 As ListObject
Dim MyTab2 As ListObject
Dim lr1 As ListRow
Dim lr2 As ListRow
Dim Gcolor As Long
 
Gcolor = RGB(0, 220, 0)
Set MyTab1 = Feuil1.ListObjects(1)
Set MyTab2 = Feuil2.ListObjects(1)
 
For Each lr1 In MyTab1.ListRows
    For Each lr2 In MyTab2.ListRows
        If lr1.Range(1) <> lr2.Range(1) And lr1.Range(2) <> lr2.Range(2) Then
           lr1.Range(1).Interior.Color = Gcolor
           lr1.Range(2).Interior.Color = Gcolor
           lr2.Range(1).Interior.Color = Gcolor
           lr2.Range(2).Interior.Color = Gcolor
        End If
    Next lr2
Next lr1
End Sub

Si tu veux a contrario l'egalité il te suifit de remplacer le "<>" par un "=". Par contre si les tableaux sont volumineux, peu etre vaudrait il mieux utiliser la fonction "find" qui est plus rapide... A voir