XL 2013 Fusionner deux tables

derlg = .Range("A" & Rows.Count).End(xlUp).Row

Option Explicit
Sub test()
Dim a, w(), i As Long, j As Long, dico As Object, n As Long, e, x, y
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    For Each e In Array("Sheet1", "Sheet2")
        a = Sheets(e).Range("a1").CurrentRegion
        For i = 2 To UBound(a, 1)
            If Not dico.exists(a(i, 1)) Then
                ReDim w(1 To UBound(a, 2), 1 To 1)
            Else
                w = dico(a(i, 1))
                ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
            End If
            For j = 1 To UBound(a, 2)
                w(j, UBound(w, 2)) = a(i, j)
            Next
            dico(a(i, 1)) = w
        Next
    Next
    x = dico.keys: y = dico.items
    With Sheets("Sheet3").Range("a1")
        .CurrentRegion.Clear
        For i = 0 To UBound(x)
            With .Offset(n).Resize(UBound(y(i), 2), UBound(y(i), 1))
                .Value = Application.Transpose(y(i))
                .Rows(1).Interior.ColorIndex = 44
                If .Rows.Count > 1 Then
                    .Offset(1).Resize(.Rows.Count - 1).Interior.ColorIndex = 43
                End If
            End With
            n = n + UBound(y(i), 2)
        Next
    End With
    Application.ScreenUpdating = True
End Sub