comparaison de 2 feuilles avec création auto d'un 3e faisant ressortir les écarts

Sub Delta()
Dim i As Long, j As Long, k As Long, v8, v9
Dim a8(), a9(), d89(), UL8 As Long, UL9 As Long, UL89 As Long, UC8 As Long, UC9 As Long
Dim r2Calc As Long
    r2Calc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    a8 = Sheets("2008").Cells(1, 1).CurrentRegion.Value
    a9 = Sheets("2009").Cells(1, 1).CurrentRegion.Value
    d89 = Sheets("ECART").Range(Cells(1, 1), Cells(1, 5)).Value
    d89 = Application.Transpose(d89)
    UL8 = UBound(a8, 1)
    UL9 = UBound(a9, 1)
    UC8 = UBound(a8, 2)
    UC9 = UBound(a9, 2)
    UL89 = 1
    Sheets.Add Before:=Sheets("ECART")
    With ActiveSheet
        .Columns("A:A").NumberFormat = "@"
        With .Range(.Cells(1, 1), .Cells(UL8 + 1, UC8))
            .Value = a8
            .Cells(UL8 + 1, 1).Value = Chr(255)
            .Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlYes, MatchCase:=True
            a8 = .Value
        End With
        .Cells.ClearContents
        With .Range(.Cells(1, 1), .Cells(UL9 + 1, UC9))
            .Value = a9
            .Cells(UL9 + 1, 1).Value = Chr(255)
            .Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlYes, MatchCase:=True
            a9 = .Value
        End With
        Application.DisplayAlerts = False
        Application.EnableEvents = False
        .Delete
        Application.EnableEvents = True
        Application.DisplayAlerts = True
    End With
    i = 2
    j = 2
    Do Until i + j > UL8 + UL9 + 1
        UL89 = UL89 + 1
        ReDim Preserve d89(1 To 5, 1 To UL89)
        v8 = a8(i, 1)
        v9 = a9(j, 1)
        If v9 = v8 Then
            For k = 1 To 4: d89(k, UL89) = a9(j, k): Next k
            d89(3, UL89) = d89(3, UL89) - a8(i, 3)
            i = i + 1: j = j + 1
        Else
            If v9 > v8 Then
                For k = 1 To 4: d89(k, UL89) = a8(i, k): Next k
                d89(3, UL89) = -a8(i, 3)
                d89(5, UL89) = 2008
                i = i + 1
            Else
                For k = 1 To 4: d89(k, UL89) = a9(j, k): Next k
                d89(5, UL89) = 2009
                j = j + 1
            End If
        End If
    Loop
    Sheets("ECART").Cells(1, 1).CurrentRegion.ClearContents
    Sheets("ECART").Range(Cells(1, 1), Cells(UL89, 5)).Value = Application.Transpose(d89)
    Application.ScreenUpdating = True
    Application.Calculation = r2Calc
End Sub

Option Explicit
Option Compare Binary

Sub communs() [COLOR="SeaGreen"]'sur une idée de BOIGONTIER,
' http://www.excel-downloads.com/forum/114504-comparaison-de-2-feuilles-avec-cr-ation-auto-dun-3e-faisant-ressortir-les-carts.html[/COLOR]
Dim t As Single [COLOR="SeaGreen"]'***[/COLOR]
    t = Timer [COLOR="SeaGreen"]'***[/COLOR]
Dim i As Long, j As Long, n1 As Long, n2 As Long, f1 As String, f2 As String, f3 As String
Dim a1, a2, d1, d2, c(), x, p
[COLOR="DarkOrange"]Dim d3, id3[/COLOR]
    Application.ScreenUpdating = False
    f1 = "2008"
    f2 = "2009"
    f3 = "Ecart"
    With Sheets(f1)
        n1 = .[a1].End(xlDown).Row
        a1 = .Range("A2:D" & n1).Value
    End With
    With Sheets(f2)
        n2 = .[a1].End(xlDown).Row
        a2 = .Range("A2:D" & n2).Value
    End With
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    [COLOR="DarkOrange"]Set d3 = CreateObject("Scripting.Dictionary")[/COLOR]
    For i = 1 To n1 - 1: d1.Add a1(i, 1), i: [COLOR="DarkOrange"]d3.Add a1(i, 1), i[/COLOR]: Next i
    For j = 1 To n2 - 1: d2.Add a2(j, 1), j
        [COLOR="DarkOrange"]If Not d3.Exists(a2(j, 1)) Then d3.Add a2(j, 1), j: i = i + 1[/COLOR]
    Next j
    [COLOR="DarkOrange"]id3 = d3.keys[/COLOR]
    Set d3 = Nothing
    [COLOR="DarkOrange"]ReDim c(1 To i - 1, 1 To 5)[/COLOR]
    For i = 1 To i - 1
        x = id3(i - 1)
        Select Case d1.Exists(x) - d2.Exists(x)
            Case 0 [COLOR="SeaGreen"]'--- communs[/COLOR]
                p = d2.Item(x)
                For j = 1 To 4: c(i, j) = a2(p, j): Next j
                c(i, 3) = c(i, 3) - a1(d1.Item(x), 3)
                c(i, 5) = "C"
            Case -1 [COLOR="SeaGreen"]'--- BD1 seul[/COLOR]
                p = d1.Item(x)
                For j = 1 To 4: c(i, j) = a1(p, j): Next j
                c(i, 3) = -c(i, 3)
                c(i, 5) = f1
            Case 1 [COLOR="SeaGreen"]'--- BD2 seul[/COLOR]
                p = d2.Item(x)
                For j = 1 To 4: c(i, j) = a2(p, j): Next j
                c(i, 5) = f2
        End Select
    Next i
    Set d1 = Nothing
    Set d2 = Nothing
    With Sheets(f3)
        .Cells(1, 1).CurrentRegion.Offset(1, 0).ClearContents
        .[a2].Resize(i - 1, 5) = c
        .[a1].CurrentRegion.Sort key1:=.[a1], order1:=xlAscending, header:=xlYes, MatchCase:=True [COLOR="SeaGreen"]'***[/COLOR]
    End With
    MsgBox "Durée d'exécution : " & Round(Timer - t, 2) & " s." [COLOR="SeaGreen"]'***[/COLOR]
 End Sub