Sub Synthese()
'Résultat dans la même feuille
Dim tablo, i As Long, j As Long, w, maxCol As Long, n As Long, txt As String
Application.ScreenUpdating = False
With Feuil1.Cells(1).CurrentRegion
tablo = .Value: maxCol = UBound(tablo, 2)
ReDim Preserve tablo(1 To UBound(tablo, 1), 1 To UBound(tablo, 2))
tablo(1, 1) = "Périodes": tablo(1, 2) = "Sites"
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(tablo, 1)
txt = Join(Array(Format(tablo(i, 1), "mmmm yyyy"), tablo(i, 2)), Chr(2))
If Not .exists(txt) Then
.Item(txt) = VBA.Array(.Count + 2, 4)
For j = 1 To 4
Select Case j
Case 1
tablo(.Item(txt)(0), j) = Application.WorksheetFunction.Proper(Format(tablo(i, j), "mmmm yyyy"))
Case 2, 3, 4
tablo(.Item(txt)(0), j) = tablo(i, j)
End Select
Next
Else
w = .Item(txt)
tablo(w(0), 3) = tablo(w(0), 3) + tablo(i, 3)
tablo(w(0), 4) = tablo(w(0), 4) + tablo(i, 4)
.Item(txt) = w
End If
Next
n = .Count + 1
End With
With .Offset(, .Columns.Count + 1).Resize(n, maxCol)
.CurrentRegion.Clear
.Value = tablo
.VerticalAlignment = xlCenter
.Font.Name = "Calibri"
.Font.Size = 12
.Borders.Weight = 2: .Columns.AutoFit
.Cells(2, 1).Resize(n - 1).RowHeight = 18
.Cells(1, 1).Resize(n).Interior.ColorIndex = 19
With .Cells(1, 2).Resize(, 3)
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 40
End With
With .Cells(2, 2).Resize(n - 1, maxCol - 1)
.Font.Size = 11
.HorizontalAlignment = xlCenter
End With
End With
End With
Application.ScreenUpdating = True
End Sub