Salut,
Colles ce 1 er jet de code dans un module, il te reste à adpater et rajouter la gestion d'erreur.
Sub Princ()
Dim C As Range, PlageListe As Range, PLageCrit As Range
Dim L&, I&, T
Application.ScreenUpdating = False
T = Array(21, 18, 15) 'L'ordre du + grand au + petit est important, Col U, R et O
With Sheets("Feuil1")
Set PlageListe = Range(.[B23], .[K65536].End(xlUp)) ' à adapter
Set PLageCrit = .Range("O25:U" & Maxi(.Name, Array("O", "R", "U"))) ' à adapter
End With
With PlageListe
Range(.Columns(2), .Columns(7)).Clear 'Effacement de la plage résultat
For Each C In .Columns(9).Cells
L = RechUnique(PLageCrit, C.Value)
For I = 0 To UBound(T)
If T(I) = L Then
Range(C, C.Offset(0, 1)).Copy C.Offset(0, -(I + I + 3))
Exit For
End If
Next I
Next C
'Moyenne,à améliorer
.Cells(65336, 9).End(xlUp).Offset(1, -6).Value = Application.Average(.Columns(3))
.Cells(65336, 9).End(xlUp).Offset(1, -4).Value = Application.Average(.Columns(5))
.Cells(65336, 9).End(xlUp).Offset(1, -2).Value = Application.Average(.Columns(7))
End With
End Sub
Function Maxi(F$, T)
Dim I&
For I = 0 To UBound(T)
Maxi = Application.Max(Maxi, Sheets(F).Range(T(I) & "65536").End(xlUp).Row)
Next I
End Function
Function RechUnique&(Plage As Range, Valeur)
Dim C As Range
With Plage
Set C = .Find(Valeur, , xlValues, xlWhole)
If Not C Is Nothing Then RechUnique = C.Column
End With
End Function
A+++
