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 |
Partager