Option Explicit
Sub test()
Dim a, w(), i As Long, n As Long, j As Byte, y, x, e, s
a = Sheets("2013").Range("a1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
Set .Item(a(i, 1)) = _
CreateObject("Scripting.Dictionary")
.Item(a(i, 1)).CompareMode = 1
End If
.Item(a(i, 1))(a(i, 2)) = _
VBA.Array(a(i, 1), a(i, 2), a(i, 3), Empty, Empty, Empty, Empty)
Next
a = Sheets("2012").Range("a1").CurrentRegion.Value
For i = 1 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
Set .Item(a(i, 1)) = _
CreateObject("Scripting.Dictionary")
.Item(a(i, 1)).CompareMode = 1
End If
If Not .Item(a(i, 1)).exists(a(i, 2)) Then
.Item(a(i, 1))(a(i, 2)) = _
VBA.Array(a(i, 1), a(i, 2), Empty, a(i, 3), Empty, Empty, Empty)
Else
w = .Item(a(i, 1))(a(i, 2))
w(3) = a(i, 3)
.Item(a(i, 1))(a(i, 2)) = w
End If
Next
For Each e In .keys
For Each s In .Item(e).keys
w = .Item(e)(s)
w(4) = w(2) - w(3)
If w(3) = 0 Then w(5) = "infini" Else w(5) = w(4) / w(3)
.Item(e)(s) = w
Next
Next
x = .keys: y = .items
End With
'Restitution et mise en forme
Application.ScreenUpdating = False
For i = 0 To UBound(x)
On Error Resume Next
Application.DisplayAlerts = False
Sheets(x(i)).Delete
On Error GoTo 0
Sheets.Add(after:=Sheets(Sheets.Count)).Name = x(i)
n = 0
With Sheets(x(i))
With .Cells(1)
.Resize(1, 7).Value = Array("Comptes", "Account", "31/12/2013", "31/12/2012", "Variations", "", "Notes")
.Offset(1).Resize(1, 7).Value = Array("", "", "", "", "Valeur", "Pourcentage", "")
With .Offset(2).Resize(y(i).Count, 7)
.Value = _
Application.Transpose(Application.Transpose(y(i).items))
n = n + .Rows.Count + 2
End With
With .Offset(n).Resize(, 7)
.Value = Array("", x(i), _
"=sum(r3c:r[-1]c)", _
"=sum(r3c:r[-1]c)", _
"=rc[-2]-rc[-1]", _
"=IF(rc[-2]>0,rc[-1]/rc[-2],""infini"")", "")
.BorderAround Weight:=xlThin
With .Offset(, 1).Resize(, .Columns.Count - 1)
.Interior.ColorIndex = 40
End With
End With
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Columns("c:e").Offset(2).Resize(.Rows.Count - 2).NumberFormat = "#,##0,"
.Columns("f").Offset(2).Resize(.Rows.Count - 2).NumberFormat = "0.00%"
'.Columns.AutoFit
.Columns.ColumnWidth = Array(16, 24, 12, 12, 12, 12, 21)
With .Rows("1:2")
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 36
.HorizontalAlignment = xlCenter
End With
For j = 1 To 4
.Cells(1, j).Resize(2).MergeCells = True
Next
.Cells(1, 7).Resize(2).MergeCells = True
.Cells(1, 5).Resize(, 2).HorizontalAlignment = xlCenterAcrossSelection
.Cells(2, 5).Resize(, 2).Borders(xlEdgeTop).Weight = xlThin
End With
End With
End With
Next
Application.ScreenUpdating = True
End Sub
