Sub Somme()
Dim datmin, datmax, mini, maxi, t, resu(), d As Object, i&, x$, lig&, j%, n&
datmin = [S2]: datmax = [T2]: mini = [U2]: maxi = [V2]
t = [A1].CurrentRegion.Resize(, 7).Offset(1)
ReDim resu(1 To UBound(t), 1 To 6)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(t) - 1
If t(i, 2) >= datmin And t(i, 2) <= datmax Then
x = Trim(t(i, 1)) & Trim(t(i, 3))
If d.exists(x) Then
lig = d(x)
For j = 4 To 7
If t(i, j) >= mini And t(i, j) <= maxi Then resu(lig, j - 1) = resu(lig, j - 1) + t(i, j)
Next j
Else
n = n + 1
d(x) = n 'mémorise la ligne
resu(n, 1) = t(i, 1): resu(n, 2) = t(i, 3)
For j = 4 To 7
resu(n, j - 1) = IIf(t(i, j) >= mini And t(i, j) <= maxi, t(i, j), 0)
Next j
End If
End If
Next i
'---restitution---
With [J12].Resize(n + 1, 6)
.Value = resu
.Offset(n).Resize(Rows.Count - n - .Row + 1).Delete xlUp
End With
End Sub