Function RngInput(Optional Prompt As String, Optional Defaut As Range) As Range
Const Title As String = "Saisie utilisateur"
If Prompt = "" Then Prompt = "Veuillez sélectionner une ou plusieurs cellules"
With Application
If Defaut Is Nothing Then
If ActiveCell Is Nothing Then
Set RngInput = .InputBox(Prompt, Title, , , , , , 8)
Else
Set RngInput = .InputBox(Prompt, Title, ActiveCell.Address, , , , , 8)
End If
Else
On Error Resume Next
Set RngInput = .InputBox(Prompt, Title, Defaut.Address, , , , , 8)
End If
End With
End Function
Sub boites()
Dim nb_crit As Integer
Dim Qx As Range
Dim Qy As Range
Dim Res As Range
Dim i As Integer
Dim c As Integer
Dim s As Integer 'N° de la ligne dans la plage sortie
Dim fin As Boolean
Dim Nouv As Boolean
Dim NouveauGroupe As Range
Dim crit() As Range
Dim DefRng As Range
Dim FirstY As Range
Dim Cat1 As String
Dim Cat2 As String
fin = False
Set DefRng = Range("A1")
Set Res = RngInput("cellule en haut à gauche de la plage de sortie", DefRng)
nb_crit = InputBox("Nombre de critères (colonnes) nécessaires pour définir une série")
For c = 1 To nb_crit
ReDim Preserve crit(c)
Set crit(c) = RngInput("Etiquette du critère N°" & c & " définissant la série", DefRng)
Res.Offset(0, c - 1) = crit(c)
Set DefRng = crit(c).Offset(0, 1)
Next c
Res.Offset(0, c - 1) = "Q1"
Res.Offset(0, c) = "min"
Res.Offset(0, c + 1) = "max"
Res.Offset(0, c + 2) = "Q3"
Res.Offset(0, c + 3) = "median"
Res.Offset(0, c + 4) = "mean"
Res.Offset(0, c + 5) = "SEM"
Res.Offset(0, c + 6) = "nbval"
Set FirstY = RngInput("Etiquette des données à analyser", DefRng)
i = 1
s = 1
Do While fin = False
Nouv = False
j = 1
'nb de données identiques sur les n critères
Cat1 = ""
For A = 1 To nb_crit
Cat1 = Cat1 & "-" & crit(1).Offset(i, A - 1)
Next A
Do While Nouv = False
Cat2 = ""
For A = 1 To nb_crit
Cat2 = Cat2 & "-" & crit(1).Offset(i + j, A - 1)
Next A
If Cat2 = Cat1 Then
j = j + 1
Else
Nouv = True
End If
Loop
Set Qy = Range(FirstY.Offset(i, 0), FirstY.Offset(i + j - 1, 0))
Q0 = Application.WorksheetFunction.Quartile(Qy, 0)
Q1 = Application.WorksheetFunction.Quartile(Qy, 1)
Q2 = Application.WorksheetFunction.Quartile(Qy, 2)
Q3 = Application.WorksheetFunction.Quartile(Qy, 3)
Q4 = Application.WorksheetFunction.Quartile(Qy, 4)
Q5 = Application.WorksheetFunction.Average(Qy)
Q6 = Application.WorksheetFunction.StDev(Qy) / Sqr(j)
Q7 = j
For A = 1 To nb_crit
Res.Offset(s, A - 1) = crit(1).Offset(i, A - 1)
Next A
Res.Offset(s, nb_crit) = Q1
Res.Offset(s, nb_crit + 1) = Q0
Res.Offset(s, nb_crit + 2) = Q4
Res.Offset(s, nb_crit + 3) = Q3
Res.Offset(s, nb_crit + 4) = Q2
Res.Offset(s, nb_crit + 5) = Q5
Res.Offset(s, nb_crit + 6) = Q6
Res.Offset(s, nb_crit + 7) = Q7
If crit(1).Offset(i + j, 0) = "" Then
fin = True
Else
i = i + j
s = s + 1
End If
Loop
End Sub
[COLOR=black]
[/COLOR]