Discussion :

[jtsfab]

Bonjour ,

Je souhaiterais comparer deux tableaux suivant une liste comparatif ! ( Pas sur que j'utilise les bons mots !!)
Sur le 1er onglet "Comparatif" , je mets le lien entre les deux tableaux : Liste 1 = Liste 2 ( et le metier concerné)
Puis viens les deux autres onglets " liste 1" et "Liste 2" avec le tableau pour chaque liste a comparer ensemble


Je souhaiterais comparer pour un même produit d'un lot diffèrent (A et B) si les colonnes de AD à NG sont différentes et si j'ai une case rempli dans l'un ca rempli l'autre qui est vide .
Tout ceci avec un découpage par métier , en ajoutant des onglets par métier . Ce qui permettra de donner le travail au bonne personne .

Et avec un code couleur , VERT quand c'est a ajouté et jaune quand il y a une différence ( si vous avez d'autres idées plus simple ou plus efficace , ne pas hésiter )

Et si pas de différence rien n'apparait dans l' onglet métier afin de n'avoir pas trop de ligne

Chaque liste peut comporter 7000 à 8000 lignes

J'espère avoir été assez clair , ce qui est moi sur !

merci d'avance et bon WE

[ARTURO83]

Bonjour,

Je suis parti du principe que toutes les feuilles "métiers" étaient déjà créées, si ce n'est pas le cas, je vous laisse le soin d'insérer ici dans le code à "Construction des tableaux par métiers", un bout de code qui se chargera de faire cela.

Pour ce que vous aviez demandé, voici:
le fichier
Pièce jointe 581192

Le code

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
Sub Recup_Donnees()
    Dim f1 As Worksheet, f2 As Worksheet, f3 As Worksheet, f4 As Worksheet
    Dim Nb_M As Long, Lig As Long, i As Long, j As Long
    Application.ScreenUpdating = False
    Set f1 = Sheets("Comparatif")
    Set f2 = Sheets("Liste 1")
    Set f3 = Sheets("Liste 2")
 
    Nb_M = f1.Range("A" & Rows.Count).End(xlUp).Row
    For f = 1 To Sheets.Count
        If Sheets(f).Name <> "Comparatif" And Sheets(f).Name <> "Liste 1" And Sheets(f).Name <> "Liste 2" Then
            Set f4 = Sheets(Sheets(f).Name)
            f4.Activate
            f4.Range("H2:O10000").Interior.ColorIndex = xlNone
            f4.Range("H2:O10000").ClearContents
            Lig = 2
 
            '*******************************************************************************************
            'Construction des tableaux par métiers
 
            '*******************************************************************************************
 
            For i = 2 To Nb_M
                If f1.Cells(i, "C") = ActiveSheet.Name Then
                    'Récupération des valeurs par formule matricielle
                    f4.Range("H" & Lig).FormulaArray = "=INDEX('Liste 1'!R1C1:R10000C13,MATCH(RC1&"" ""&RC4,'Liste 1'!C1&"" ""&'Liste 1'!C2,0),MATCH(R1C,'Liste 1'!R1,0))"
                    f4.Range("H" & Lig).AutoFill Destination:=f4.Range("H" & Lig & ":O" & Lig), Type:=xlFillDefault
                    f4.Range("H" & Lig & ":O" & Lig).Value = f4.Range("H" & Lig & ":O" & Lig + 1).Value
                    f4.Range("H" & Lig + 1).FormulaArray = "=INDEX('Liste 2'!R1C1:R10000C13,MATCH(RC1&"" ""&RC4,'Liste 2'!C1&"" ""&'Liste 2'!C2,0),MATCH(R1C,'Liste 2'!R1,0))"
                    f4.Range("H" & Lig + 1).AutoFill Destination:=f4.Range("H" & Lig + 1 & ":O" & Lig + 1), Type:=xlFillDefault
                    f4.Range("H" & Lig + 1 & ":O" & Lig + 1).Value = f4.Range("H" & Lig + 1 & ":O" & Lig + 1).Value
 
                    'Application des couleurs
                    For j = 8 To 15 'de AD à NG
                        If f4.Cells(Lig, j) <> f4.Cells(Lig + 1, j) Then
                            If f4.Cells(Lig, j) <> 0 And f4.Cells(Lig + 1, j) <> 0 Then
                                f4.Range(f4.Cells(Lig, j), f4.Cells(Lig + 1, j)).Interior.ColorIndex = 6
                            ElseIf f4.Cells(Lig, j) = 0 And f4.Cells(Lig + 1, j) <> 0 Then
                                f4.Cells(Lig, j) = f4.Cells(Lig + 1, j)
                                f4.Cells(Lig, j).Interior.ColorIndex = 4
                            ElseIf f4.Cells(Lig, j) <> 0 And f4.Cells(Lig + 1, j) = 0 Then
                                f4.Cells(Lig + 1, j) = f4.Cells(Lig, j)
                                f4.Cells(Lig + 1, j).Interior.ColorIndex = 4
                            End If
                        ElseIf f4.Cells(Lig, j) = 0 And f4.Cells(Lig + 1, j) = 0 Then
                            f4.Range(f4.Cells(Lig, j), f4.Cells(Lig + 1, j)).Value = ""
                        End If
                    Next j
                    Lig = Lig + 3
                End If
            Next i
        End If
    Next f
End Sub

Cdlt

[jtsfab]

Merci ARTHURO83 pour le boulot , nickel

Malheureusement je suis une chèvre en VBA

Et les onglets RO à CH ne sont pas créer , même pas les feuilles ( bon ca je pourrais faire )

Pourrais tu m'aider a finir ?
Pour que les tableaux dans les onglets métiers se crée tout seuls ? ( j'ai bq plus de métiers que cela !! )

encore merci pour ton aide

Cdt

[EricDgn]

Bonjour,

Une autre façon de faire (tous les chemins mènent à Rome), qui crée les feuilles si nécessaire, et qui les vident avant de commencer. Dans cette solution, il n'y a que des copiés collés, pas de formule inscrite.

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
Option Explicit
 
Public Sub Comparer()
    Dim wSh As Worksheet, wSh1 As Worksheet, wSh2 As Worksheet, wShM As Worksheet
    Dim kR As Long, kR1 As Long, kR2 As Long, kRM As Long, kC As Long
    Dim Rng As Range, Rng1 As Range, Rng2 As Range, PM1 As Long, PM2 As Long
    Dim bNoDiff As Boolean, sMetier As String
    '--- vider les feuilles Metiers (sans remettre ligne de titre)
    For Each wSh In ThisWorkbook.Worksheets
        Select Case wSh.Name
            Case "Comparatif", "Liste 1", "Liste 2"
                '--- ne rien faire
            Case Else
                wSh.Cells.Clear         '--- vide entièrement la feuille
        End Select
    Next wSh
    '--- intialise
    Dim t As Single:    t = Timer
    Set wSh = ThisWorkbook.Worksheets("Comparatif")
    Set wSh1 = ThisWorkbook.Worksheets("Liste 1")
    Set wSh2 = ThisWorkbook.Worksheets("Liste 2")
    kR = 1
    '--- parourir "Comparatif"
    Do
        kR = kR + 1
        If wSh.Cells(kR, 1) = "" Then GoTo fin      '--- sortie
        PM1 = wSh.Cells(kR, 1).Value
        PM2 = wSh.Cells(kR, 2).Value
        If Application.WorksheetFunction.CountIf(wSh1.Range("A:A"), PM1) > 1 Then
            MsgBox "Il y a plusieurs fois le même PM (" & PM1 & ")" & vbLf & _
                    "utilisé dans la feuille " & wSh1.Name, , "Opération interrompue"
            GoTo fin                                '--- sortie
        End If
        If Application.WorksheetFunction.CountIf(wSh2.Range("A:A"), PM2) > 1 Then
            MsgBox "Il y a plusieurs fois le même PM (" & PM2 & ")" & vbLf & _
                    "utilisé dans la feuille " & wSh2.Name, , "Opération interrompue"
            GoTo fin                                '--- sortie
        End If
        sMetier = wSh.Cells(kR, 3).Value
        If Not Sheet_Exists(sMetier) Then
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = sMetier
        End If
        Set Rng1 = wSh1.Range("A:A").Find(wSh.Cells(kR, 1))
        Set Rng2 = wSh2.Range("A:A").Find(wSh.Cells(kR, 2))
        If Rng1 Is Nothing Or Rng2 Is Nothing Then
            MsgBox "Ligne " & kR & " avec un n° de liste non trouvée", , "Opération interrompue"
            wSh.Cells(kR, 1).Select
            GoTo fin                                '--- sortie
        End If
        kR1 = Rng1.Row
        kR2 = Rng2.Row
        '--- détecte différence éventuelle
        bNoDiff = True
        For kC = 7 To 13
            If wSh1.Cells(kR1, kC) <> wSh2.Cells(kR2, kC).Value Then
                bNoDiff = False
                Exit For
            End If
        Next kC
        If bNoDiff = False Then            '--- si différence constatée
            Set wShM = ThisWorkbook.Worksheets(sMetier)
            kRM = wShM.Cells(Rows.Count, 1).End(xlUp).Row + 1
            '--- recopier
            wSh.Cells(kR, 1).Copy wShM.Cells(kRM, 1)        '--- PM
            wSh.Cells(kR, 3).Copy wShM.Cells(kRM, 3)        '--- Métier
            wSh1.Cells(kR1, 2).Copy wShM.Cells(kRM, 4)      '--- Lot
            wSh1.Range(wSh1.Cells(kR1, 6), wSh1.Cells(kR1, 13)).Copy wShM.Cells(kRM, 8)
            wSh.Cells(kR, 2).Copy wShM.Cells(kRM + 1, 1)    '--- PM
            wSh.Cells(kR, 3).Copy wShM.Cells(kRM + 1, 3)    '--- Métier
            wSh2.Cells(kR2, 2).Copy wShM.Cells(kRM + 1, 4)  '--- Lot
            wSh2.Range(wSh2.Cells(kR2, 6), wSh2.Cells(kR2, 13)).Copy wShM.Cells(kRM + 1, 8)
            '--- marquer différences
            For kC = 8 To 15
                If wShM.Cells(kRM, kC) <> wShM.Cells(kRM + 1, kC) Then
                    If wShM.Cells(kRM, kC) = "" Then
                        wShM.Cells(kRM, kC).Interior.Color = 3394611        '--- vert
                        wShM.Cells(kRM, kC).Value = wShM.Cells(kRM + 1, kC).Value
                    ElseIf wShM.Cells(kRM + 1, kC) = "" Then
                        wShM.Cells(kRM + 1, kC).Interior.Color = 3394611    '--- vert
                        wShM.Cells(kRM + 1, kC).Value = wShM.Cells(kRM, kC).Value
                    Else
                        wShM.Cells(kRM + 1, kC).Interior.Color = 65535      '--- jaune
                    End If
                End If
            Next kC
        End If
    Loop
fin:
    Set Rng2 = Nothing
    Set Rng1 = Nothing
    Set wShM = Nothing
    Set wSh2 = Nothing
    Set wSh1 = Nothing
    Set wSh = Nothing
    Debug.Print Timer - t
End Sub
 
Public Function Sheet_Exists(wshName As String) As Boolean
   On Error Resume Next
   Sheet_Exists = CBool(Len(Worksheets(wshName).Name) > 0)
End Function

Avec ces 2 versions, tu devrais pouvoir faire la tienne!
Note: s'il y a 2 cellules vides, cela sera considéré comme "égal".
Cordialement.

[jtsfab]

Merci EricDgn

Oui les deux combinés m'iraient parfaitement

L'un a un bouton et les tableaux sont bien séparés mais obligation de les creer

et le tien fait les onglets mais n'a pas de bouton et de separe pas les differentes combinaisons et ne mets pas les libelles sur les tableaux

Si une ame charitable peut arriver a compiler les deux

En tout cas merci pour votre aide EricDgn et Arthuro83 , et d'avoir passé du temps pour m'aider

Cdt

[ARTURO83]

Bon je vois que EricDgn () à fait le boulot, je complète son code pour les petites modifications demandées

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
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
 
Option Explicit
 
Public Sub Comparer()
    Dim wSh As Worksheet, wSh1 As Worksheet, wSh2 As Worksheet, wShM As Worksheet
    Dim kR As Long, kR1 As Long, kR2 As Long, kRM As Long, kC As Long
    Dim Rng As Range, Rng1 As Range, Rng2 As Range, PM1 As Long, PM2 As Long
    Dim bNoDiff As Boolean, sMetier As String
 
    Application.ScreenUpdating = False
    '--- vider les feuilles Metiers (sans remettre ligne de titre)
    For Each wSh In ThisWorkbook.Worksheets
        Select Case wSh.Name
            Case "Comparatif", "Liste 1", "Liste 2"
                '--- ne rien faire
            Case Else
                wSh.Cells.Clear         '--- vide entièrement la feuille
        End Select
    Next wSh
    '--- intialise
    Dim t As Single:    t = Timer
    Set wSh = ThisWorkbook.Worksheets("Comparatif")
    Set wSh1 = ThisWorkbook.Worksheets("Liste 1")
    Set wSh2 = ThisWorkbook.Worksheets("Liste 2")
    kR = 1
    '--- parourir "Comparatif"
    Do
        kR = kR + 1
        If wSh.Cells(kR, 1) = "" Then GoTo fin      '--- sortie
        PM1 = wSh.Cells(kR, 1).Value
        PM2 = wSh.Cells(kR, 2).Value
        If Application.WorksheetFunction.CountIf(wSh1.Range("A:A"), PM1) > 1 Then
            MsgBox "Il y a plusieurs fois le même PM (" & PM1 & ")" & vbLf & _
                    "utilisé dans la feuille " & wSh1.Name, , "Opération interrompue"
            GoTo fin                                '--- sortie
        End If
        If Application.WorksheetFunction.CountIf(wSh2.Range("A:A"), PM2) > 1 Then
            MsgBox "Il y a plusieurs fois le même PM (" & PM2 & ")" & vbLf & _
                    "utilisé dans la feuille " & wSh2.Name, , "Opération interrompue"
            GoTo fin                                '--- sortie
        End If
        sMetier = wSh.Cells(kR, 3).Value
        If Not Sheet_Exists(sMetier) Then
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = sMetier
            Range("A1:O1") = Array("PM", "", "Libellé", "LOT", "", "", "", "AD", "AS", "EC", "DS", "GD", "DL", "MI", "NG")
            Range("A1:O1").Select
            With Range("A1:O1")
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlBottom
                .Font.Bold = True
                .Interior.Color = RGB(204, 204, 0)
            End With
            With Selection.Borders()
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
 
        End If
        Set Rng1 = wSh1.Range("A:A").Find(wSh.Cells(kR, 1))
        Set Rng2 = wSh2.Range("A:A").Find(wSh.Cells(kR, 2))
        If Rng1 Is Nothing Or Rng2 Is Nothing Then
            MsgBox "Ligne " & kR & " avec un n° de liste non trouvée", , "Opération interrompue"
            wSh.Cells(kR, 1).Select
            GoTo fin                                '--- sortie
        End If
        kR1 = Rng1.Row
        kR2 = Rng2.Row
        '--- détecte différence éventuelle
        bNoDiff = True
        For kC = 7 To 13
            If wSh1.Cells(kR1, kC) <> wSh2.Cells(kR2, kC).Value Then
                bNoDiff = False
                Exit For
            End If
        Next kC
        If bNoDiff = False Then            '--- si différence constatée
            Set wShM = ThisWorkbook.Worksheets(sMetier)
            kRM = wShM.Cells(Rows.Count, 1).End(xlUp).Row
            If kRM = 1 Then kRM = kRM + 1 Else: kRM = kRM + 2
            '--- recopier
            wSh.Cells(kR, 1).Copy wShM.Cells(kRM, 1)        '--- PM
            wSh.Cells(kR, 3).Copy wShM.Cells(kRM, 3)        '--- Métier
            wSh1.Cells(kR1, 2).Copy wShM.Cells(kRM, 4)      '--- Lot
            wSh1.Range(wSh1.Cells(kR1, 6), wSh1.Cells(kR1, 13)).Copy wShM.Cells(kRM, 8)
            wSh.Cells(kR, 2).Copy wShM.Cells(kRM + 1, 1)    '--- PM
            wSh.Cells(kR, 3).Copy wShM.Cells(kRM + 1, 3)    '--- Métier
            wSh2.Cells(kR2, 2).Copy wShM.Cells(kRM + 1, 4)  '--- Lot
            wSh2.Range(wSh2.Cells(kR2, 6), wSh2.Cells(kR2, 13)).Copy wShM.Cells(kRM + 1, 8)
            With wShM.Range(wShM.Cells(kRM, 1), wShM.Cells(kRM + 1, 15)).Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
 
            '--- marquer différences
            For kC = 8 To 15
                If wShM.Cells(kRM, kC) <> wShM.Cells(kRM + 1, kC) Then
                    If wShM.Cells(kRM, kC) = "" Then
                        wShM.Cells(kRM, kC).Interior.Color = 3394611        '--- vert
                        wShM.Cells(kRM, kC).Value = wShM.Cells(kRM + 1, kC).Value
                    ElseIf wShM.Cells(kRM + 1, kC) = "" Then
                        wShM.Cells(kRM + 1, kC).Interior.Color = 3394611    '--- vert
                        wShM.Cells(kRM + 1, kC).Value = wShM.Cells(kRM, kC).Value
                    Else
                        wShM.Cells(kRM + 1, kC).Interior.Color = 65535      '--- jaune
                    End If
                End If
            Next kC
        End If
    Loop
fin:
    Set Rng2 = Nothing
    Set Rng1 = Nothing
    Set wShM = Nothing
    Set wSh2 = Nothing
    Set wSh1 = Nothing
    Set wSh = Nothing
End Sub

Cdlt