'### Constantes à adapter ###
Const FIRST_CELL_DATA As String = "A1"
Const FIRST_CELL_CRITERE As String = "M1"
'############################
Sub FitreElaboreMoyennes()
Dim S As Worksheet
Dim R As Range
Dim R2 As Range
Dim Lig&
Dim nbCol&
Dim i&
Dim A$
On Error GoTo Erreur
ActiveSheet.Copy After:=Sheets(ActiveSheet.Index)
Set S = ActiveSheet
Set R = S.Range(FIRST_CELL_DATA).CurrentRegion
nbCol& = R.Columns.Count
Set R2 = S.Range(FIRST_CELL_CRITERE).CurrentRegion
Lig& = R.Rows.Count + 1
R2.Copy Destination:=R.Offset(Lig&, 0)
Application.CutCopyMode = False
Lig& = Lig& + R2.Rows.Count + 1
R.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=R2, _
CopyToRange:=R.Offset(Lig&, 0), Unique:=False
Set R = S.Range(FIRST_CELL_DATA).Offset(Lig&, 0).CurrentRegion
Set R = R.Offset(1, 0).Resize(R.Rows.Count - 1, 1)
For i& = 2 To nbCol&
Set R = R.Offset(0, 1)
Set R2 = R.Offset(3, 0).Resize(1, 1)
R2.Formula = "=AVERAGE(" & R.Address(False, False) & ")"
Next i&
Erreur:
If Err <> 0 Then
Application.DisplayAlerts = False
If Not S Is Nothing Then S.Delete
Application.DisplayAlerts = True
A$ = "Erreur " & Err.Number & vbCrLf & Err.Description
If Err = 1004 Then
A$ = A$ & vbCrLf & vbCrLf & "La 1ère cellule des données doit être " & FIRST_CELL_DATA & _
vbCrLf & "La 1ère cellule des critères doit être " & FIRST_CELL_CRITERE
End If
MsgBox A$
End If
End Sub