Sub GrandesValeurs()
Dim Pl As Range, PlObj As Range, PlQT As Range, PlQS As Range, dico As Object, i&, j&, T, T2(), c, temp
Dim firstAddress, NCS As Double, MaxQT As Double, MaxQS As Double
With Sheets("David")
Set Pl = .Range("A1:G" & .Range("A" & Rows.Count).End(xlUp).Row)
Set dico = CreateObject("Scripting.Dictionary")
T = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
For Each c In T
dico(c) = dico(c)
Next c
temp = dico.keys
ReDim T2(dico.Count, 3)
For i = LBound(temp) To UBound(temp)
T2(i, 0) = temp(i)
Set c = Pl.Columns(1).Find(temp(i), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then firstAddress = c.Address
MaxQT = Application.Evaluate("MAX(IF(" & Pl.Columns(1).Address(External:=True) & _
"=" & c.Address & "," & Pl.Columns(7).Address(External:=True) & "))")
MaxQS = Application.Evaluate("MAX(IF(" & Pl.Columns(1).Address(External:=True) & _
"=" & c.Address & "," & Pl.Columns(6).Address(External:=True) & "))")
For j = 1 To Pl.Rows.Count
If Pl(j, 1) = temp(i) And (Pl(j, 7) = MaxQT Or Pl(j, 6) = MaxQS) And Pl(j, 2) > NCS Then NCS = Pl(j, 2)
Next j
T2(i, 1) = NCS: NCS = 0
T2(i, 2) = MaxQS
T2(i, 3) = MaxQT
Next i
.[J2].Resize(UBound(T2) + 1, UBound(T2, 2) + 1) = T2
End With
End Sub