Private Sub Worksheet_Activate()
Dim t, a(), d As Object, i&, sex As Byte, n&
t = Feuil1.[A1].CurrentRegion.Resize(, 4) 'Feuil1=CodeName de la feuille source
ReDim a(1 To UBound(t), 1 To 12)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
If Not d.exists(t(i, 1)) Then
d(t(i, 1)) = d.Count + 1 'élimine les doublons et repère la ligne
a(d.Count, 1) = t(i, 1)
End If
sex = 0
If UCase(t(i, 4)) = "M" Then sex = 1 Else _
If UCase(t(i, 4)) = "MME" Or UCase(t(i, 4)) = "MELLE" Then sex = 2
n = d(t(i, 1))
If sex = 1 Then a(n, 2) = a(n, 2) + t(i, 2) Else _
If sex = 2 Then a(n, 3) = a(n, 3) + t(i, 2)
If t(i, 3) < 15 Then
a(n, 4) = a(n, 4) + t(i, 2)
If sex = 1 Then a(n, 7) = a(n, 7) + t(i, 2) Else _
If sex = 2 Then a(n, 10) = a(n, 10) + t(i, 2)
ElseIf t(i, 3) <= 35 Then
a(n, 5) = a(n, 5) + t(i, 2)
If sex = 1 Then a(n, 8) = a(n, 8) + t(i, 2) Else _
If sex = 2 Then a(n, 11) = a(n, 11) + t(i, 2)
Else
a(n, 6) = a(n, 6) + t(i, 2)
If sex = 1 Then a(n, 9) = a(n, 9) + t(i, 2) Else _
If sex = 2 Then a(n, 12) = a(n, 12) + t(i, 2)
End If
Next
'---restitution et mise en forme---
Application.ScreenUpdating = False
Range("A4:L" & Rows.Count).Delete xlUp 'RAZ
If d.Count Then
With [A4].Resize(d.Count, 12)
.Value = a
.Sort .Columns(1), xlAscending, Header:=xlNo 'tri
.Rows(d.Count + 1) = "=SUM(R[-" & .Rows.Count & "]C:R[-1]C)"
.Cells(d.Count + 1, 1) = "Total"
.Rows(d.Count + 1).Font.Bold = True 'gras
.Rows(d.Count + 1).Font.ColorIndex = 3 'rouge (facultatif)
.Resize(d.Count + 1).Borders.Weight = xlThin 'bordures
End With
End If
End Sub