Comparaison de 2 feuilles & repérage des lignes différentes

Question

J'ai besoin de votre aide pour écrire une macro. J'ai deux feuilles avec beaucoup de données (600 lignes), qui sont de structures identiques. Je récupère ces données semaine par semaine, et malheureusement il arrive que des données se rajoutent en retard. Du coup ces données sont identiques avec d'une semaine à l'autre des lignes qui se rajoutent mais qui existent déjà ! C'est pourquoi j'aimerais pouvoir comparer toutes les lignes de ces deux feuilles, et repérer les lignes qui sont différentes d'une semaine à l'autre. Pour connaitre de ce fait les données qui on été rajouté en retard. L'idéal serait que les lignes concernées soient surlignées dans l'onglet où elles apparaissent déjà, et qu'elles soient isolées dans un autre onglet (copier/coller de toutes ces lignes surlignées dans un nouvel onglet). Alors je vous cache pas que j'ai aucune idée de comment faire, puis l'écrire en VBA encore moins ... Je vous joins un fichier exemple, avec en onglet la semaine n-1 et n. N'hésitez pas si j'ai manqué de précisions. Un grand merci par avance ...

Klin89 · Accepted Answer

Re nicococo,

Bonjour patrick1957

Tu voulais recopier les lignes concernées dans un nouvel onglet, j'ai modifié le code en ce sens.

N'oublie pas de créer une feuille nommée "Feuil1".

Option Explicit

Sub Surligne_rajout()
Dim a, i As Long, j As Long, txt As String, dico As Object, x As Range
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    With Sheets("Week n-1").Cells(1).CurrentRegion
        For i = 2 To .Rows.Count
            For j = 1 To .Columns.Count
                txt = txt & Chr(2) & .Cells(i, j).Value
            Next
            dico(txt) = Empty
            txt = ""
        Next
    End With
    With Sheets("Week n").Cells(1).CurrentRegion
        .Interior.ColorIndex = xlNone
        For i = 2 To .Rows.Count
            For j = 1 To .Columns.Count
                txt = txt & Chr(2) & .Cells(i, j).Value
            Next
            If Not dico.exists(txt) Then
                If x Is Nothing Then
                    Set x = .Rows(i)
                Else
                    Set x = Union(x, .Rows(i))
                End If
            End If
            txt = ""
        Next
        If Not x Is Nothing Then
            x.Interior.ColorIndex = 42
            Set x = Union(.Rows(1), x)
            x.Copy Sheets("Feuil1").Cells(1)
            With Sheets("Feuil1").Cells(1).CurrentRegion
                .Sort key1:=.Cells(1), order1:=1, Header:=xlYes
                .Interior.ColorIndex = xlNone
                .Font.Name = "calibri"
                .Font.Size = 10
                .VerticalAlignment = xlCenter
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .Interior.ColorIndex = 38
                End With
                .Columns.AutoFit
            End With
        Else
            MsgBox "Aucun rajout"
        End If
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Klin89 · Answer

Si j'ai bien compris : Dans "Week n", on surligne les enregistrements ne figurant pas dans "Week n-1" Option Explicit Sub Surligne_rajout() Dim a, i As Long, j As Long, txt As String, dico As Object, x As Range Application.ScreenUpdating = False Set dico = CreateObject("Scripting.Dictionary") With Sheets("Week n-1").Cells(1).CurrentRegion For i = 2 To .Rows.Count For j = 1 To .Columns.Count txt = txt &amp; Chr(2) &amp; .Cells(i, j).Value Next dico(txt) = Empty txt = "" Next End With With Sheets("Week n").Cells(1).CurrentRegion .Interior.ColorIndex = xlNone For i = 2 To .Rows.Count For j = 1 To .Columns.Count txt = txt &amp; Chr(2) &amp; .Cells(i, j).Value Next If Not dico.exists(txt) Then If x Is Nothing Then Set x = .Rows(i) Else Set x = Union(x, .Rows(i)) End If End If txt = "" Next If Not x Is Nothing Then x.Interior.ColorIndex = 42 Else MsgBox "Aucun rajout" End If End With Application.ScreenUpdating = True End Sub klin89...

patrick1957 · Answer

Après cet excellent code , je n'ajouterai qu'une chose en plus des couleurs qui permettent de repérer facilement: à cet endroit If Not dico.Exists(txt) Then If x Is Nothing Then Set x = .Rows(i) Cells(i, 28) = "x" ' ajout d'un X pour un éventuel tri sur celui-ci en colonne AB Else Set x = Union(x, .Rows(i)) Cells(i, 28) = "x" ' ajout d'un X pour un éventuel tri sur celui-ci en colonne AB End If End If Tu peux alors ajouter un titre à ta colonne AB et trier sur celle-ci...