Sub Synthese()
'Résultat dans une autre feuille
Dim a, i As Long, j As Long, w, maxCol As Byte, n As Long, txt As String
Application.ScreenUpdating = False
With Sheets("rapport").Range("A1").CurrentRegion
a = .Value: maxCol = UBound(a, 2)
ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2))
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
'le code 1 seulement
If a(i, 2) = 1 Then
txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))
If Not .exists(txt) Then
.Item(txt) = VBA.Array(.Count + 2, 3)
For j = 1 To 3
a(.Item(txt)(0), j) = a(i, j)
Next
Else
w = .Item(txt)
a(w(0), 3) = a(w(0), 3) + a(i, 3)
.Item(txt) = w
End If
End If
Next
n = .Count + 1
End With
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Recap").Delete
On Error GoTo 0
Sheets.Add(before:=Sheets(1)).Name = "Recap"
With Sheets("Recap").Cells(1, 1).Resize(n, maxCol)
.CurrentRegion.Clear
.Value = a
.Columns(1).Interior.ColorIndex = 19
.Rows(1).Interior.ColorIndex = 43
.VerticalAlignment = xlCenter
.Columns(2).HorizontalAlignment = xlCenter
.Font.Name = "Calibri"
.Font.Size = 12
.Borders.Weight = 2: .Columns.AutoFit
End With
End With
Application.ScreenUpdating = True
End Sub