Comparer deux classeurs et faire ressortir les differences

Bonjour a tous,

je me permets de solliciter votre aide une seconde fois pour élucider un problème de vbA.

Pour vous situer le contexte je travaille chaque mois sur un fichier comprenant une vingtaine d'onglets, un onglet = un projet. Je souhaiterais mettre en place une macro qui me permettrait de comparer les donnes entre les mois. Par exemple j'aimerais comparer les données du mois de Juin pour chaque projet avec celles de Mai pour chaque projet, afin de voir toutes les lignes qui ont évolué .

Dans mes deux classeurs les onglets qui correspondent aux différents projets ont les memes noms, dans la mesure ou les noms des projets n'évoluent pas. Ci-joint un exemple simplifié des fichiers sur lesquels je travaille.

Je commençais a travailler sur la macro suivante qui me permet de comparer une feuille d'un classeur avec une feuille d'un autre, cependant j'aimerai l'automatiser pour résoudre mon problème ci-dessus et que la macro compare le budget X de Mai avec le budget X de Juin, le budget Y de Mai avec le budget Y de Juin et ainsi de suite dans la mesure ou les onglets ont les memes noms. Est-ce que vous auriez des suggestions ? Encore une fois merci d'avance a tous ceux qui prendront du temps pour m'aider !

Sub test() 
    Dim a, i As Long, ii As Long, w(), b(), n As Long, y, z As String 
    With Workbooks("test.xls").Sheets(1) 
        a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(,9).Value 
    End With 
    With CreateObject("Scripting.Dictionary") 
        .CompareMOde = vbTextCompare 
        For i = 2 To UBound(a,1) 
            If Not IsEmpty(a(i,1)) Then 
                z = Join(Array(a(i,1), a(i,2), a(i,3), a(i,4)),";") 
                If Not .exists(z) Then 
                    Redim w(1 To UBound(a,2)) 
                    For ii = 1 To UBound(a,2) : w(ii) = a(i,ii) : Next 
                        .add z, w 
                    End If 
                End If 
            Next 
            With ThisWorkbook.Sheets("sheet1") 
                a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(,9).Value 
            End With 
            Redim b(1 To UBound(a,1), 1 To UBound(a,2)) 
            For i = 2 To UBound(a,1) 
                If Not IsEmpty(a(i,1)) Then 
                    z = Join(Array(a(i,1), a(i,2), a(i,3), a(i,4)),";") 
                    If .exists(z) Then 
                        w = .item(z) 
                        For ii = 5 To UBound(a,2) 
                            If w(ii) <> a(i,ii) Then 
                                ThisWorkbook.Sheets("sheet1").Cells(i,ii).Interior.Color = vbRed 
                            End If 
                        Next 
                        .remove(z) 
                    Else 
                        n = n + 1 
                        For ii = 1 To UBound(a,2) 
                            b(n,ii) = a(i,ii) 
                        Next 
                    End If 
                End If 
            Next 
            If .count > 0 Then y = Application.Transpose(Application.Transpose(.items)) 
        End With 
        With ThisWorkbook.Sheets("sheet2").Range("a1") 
            .CurrentRegion.ClearContents 
            .Resize(,11).Value = [{"Only in Book2","","","","","","","","","","Only in Here"}] 
            If IsArray(x) Then .Offset(1).Resize(UBound(y,1) + 1, 9).Value = y 
            If n > 0 Then .Offset(,10).Resize(n,9).Value = b 
        End With 
    End Sub

Re-bonjour Alexis,

Juste deux conseils si tu veux avoir pas mal de réponses.

1/ Copie ton code avec la balise Code:

2/ Si tu peux fournir un fichier en exemple avec des chiffes annonymes par exemple.

Sub test() 
Dim a, i As Long, ii As Long, w(), b(), n As Long, y, z As String 
With Workbooks("test.xls").Sheets(1) 
a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(,9).Value 
End With 
With CreateObject("Scripting.Dictionary") 
.CompareMOde = vbTextCompare 
For i = 2 To UBound(a,1) 
If Not IsEmpty(a(i,1)) Then 
z = Join(Array(a(i,1), a(i,2), a(i,3), a(i,4)),";") 
If Not .exists(z) Then 
Redim w(1 To UBound(a,2)) 
For ii = 1 To UBound(a,2) : w(ii) = a(i,ii) : Next 
.add z, w 
End If 
End If 
Next 
With ThisWorkbook.Sheets("sheet1") 
a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(,9).Value 
End With 
Redim b(1 To UBound(a,1), 1 To UBound(a,2)) 
For i = 2 To UBound(a,1) 
If Not IsEmpty(a(i,1)) Then 
z = Join(Array(a(i,1), a(i,2), a(i,3), a(i,4)),";") 
If .exists(z) Then 
w = .item(z) 
For ii = 5 To UBound(a,2) 
If w(ii) <> a(i,ii) Then 
ThisWorkbook.Sheets("sheet1").Cells(i,ii).Interior.Color = vbRed 
End If 
Next 
.remove(z) 
Else 
n = n + 1 
For ii = 1 To UBound(a,2) 
b(n,ii) = a(i,ii) 
Next 
End If 
End If 
Next 
If .count > 0 Then y = Application.Transpose(Application.Transpose(.items)) 
End With 
With ThisWorkbook.Sheets("sheet2").Range("a1") 
.CurrentRegion.ClearContents 
.Resize(,11).Value = [{"Only in Book2","","","","","","","","","","Only in Here"}] 
If IsArray(x) Then .Offset(1).Resize(UBound(y,1) + 1, 9).Value = y 
If n > 0 Then .Offset(,10).Resize(n,9).Value = b 
End With 
End Sub

@+ et bonne journée.

Re-bonjour, ok merci du conseil je mettrai deux fichiers en exemple des que possible.

Je me sens un peu comme Achille dans Troie au debut du film, en version plus désespérée certes :"Il n'y a personne d'autre ??".

Bonjour à tous

Un essai à tester.

Bye !