' ******************************************
' *                                        *
' *   Fichier BOXPLOTS.TXT                 *
' *                                        *
' ******************************************

Option Explicit

'auteur : Claude Monteil - INP/ENSAT Toulouse - mailto:monteil@ensat.fr
'version 1.0 : 23 fév 05
'version 1.1 : 2 mar 05 :
' - affichage du nombre de points atypiques au-dessus et au-dessous des moustaches
' - mise en rouge des mini ou maxi s'ils sont atypiques
' - prise en compte des noms de feuilles avec caractères spéciaux (tiret, espace, ...etc.)
' - amélioration de mise en forme (quadrillage du tableau, dimensionnement du graphique)
'version 1.2 : 4 mars 05 : ajout d'une ligne avec l'effectif des données

' ==================================================

Const TITRE = "CREATION DE BOITES A MOUSTACHES"

' ==================================================

Sub CreerFeuilleBoxPlot()

' ==================================================

'crée une nouvelle feuille contenant un tableau des statistiques des séries contenues dans la sélection
'en cours, et un affichage graphique de ce tableau sous forme de boîtes à moustaches (box plots)
'NOTA : vérifie que la sélection contient bien une plage de nombres avec en-tête de libellés

   'vérification qu'il existe une sélection non atomique
    If Selection.Cells.Count = 1 Then
        MsgBox "Sélectionner préalablement une série de données", vbExclamation, TITRE

   'vérification 1ere ligne = ligne de libellés
    ElseIf Not PlageTextuelle(Selection.Rows(1)) Then
        MsgBox "La 1ère ligne de la sélection doit contenir les libellés des séries", vbExclamation, TITRE

   'vérification autres lignes = des nombres exclusivement
    ElseIf Not PlageNumerique(Selection.Offset(1).Resize(Selection.Rows.Count - 1)) Then
        MsgBox "La sélection (hors 1ère ligne d'en-tête) doit contenir des valeurs numériques", vbExclamation, TITRE

   'création du tableau des statistiques puis des boîtes à moustache
    Else
        CreerStats Selection
        CreerBoitesAMoustaches Selection
    End If

End Sub

' ==================================================

Sub CreerStats(Donnees As Range)

' ==================================================

'crée une nouvelle feuille de nom "BoxPlotN" (où N=1er numéro d'ordre libre en partant de 1)
'contenant les statistiques descriptives (q1,min,med,max,q3) de séries de données en colonnes
'ENTREE Donnees : plage contenant les séries en colonnes, avec 1ère ligne = nom des séries
'SORTIE GLOBALE Selection : sélection sur la nouvelle plage créée

    Const PREFIXE = "BoxPlot" 'préfixe du nom de la feuille ajoutée
    Dim FeuilleBoxPlot As Worksheet, n As Integer
    Dim NomFeuilleDonnees As String, Nom1erePlage As String

   'création d'une nouvelle feuille et nommage
    Set FeuilleBoxPlot = Sheets.Add
    n = 1
    Do While ExisteFeuille(PREFIXE & n): n = n + 1: Loop
    FeuilleBoxPlot.Name = PREFIXE & n
    FeuilleBoxPlot.Select

   '1ere colonne : libellés de chaque variable descriptive
    [A1] = "NOM":         [A2] = "q1":  [A3] = "min"
    [A4] = "moust. inf.": [A5] = "med": [A6] = "moy"
    [A7] = "moust. sup.": [A8] = "max": [A9] = "q3"
    [A10] = "nb atyp. inf.": [A11] = "nb atyp. sup.": [A12] = "effectif"

   '2eme colonne : calcul des variables pour la 1ere colonne de données
    NomFeuilleDonnees = "'" & Donnees.Worksheet.Name & "'!"
      'Encadrer le nom de feuille par ' ' est indispensable pour les feuilles contenant un -
    Nom1erePlage = NomFeuilleDonnees & Donnees.Columns(1).Address(ColumnAbsolute:=False)
    [B1] = "=" & NomFeuilleDonnees & Donnees.Cells(1).Address(ColumnAbsolute:=False)
    [B2] = "=QUARTILE(" & Nom1erePlage & ",1)"
    [B3] = "=MIN(" & Nom1erePlage & ")"
    [B4] = "=PlusPetiteValeurSuperieureA(" & Nom1erePlage & ",B$2-1.5*(B$9-B$2))"
    [B5] = "=MEDIAN(" & Nom1erePlage & ")"
    [B6] = "=AVERAGE(" & Nom1erePlage & ")"
    [B7] = "=PlusGrandeValeurInferieureA(" & Nom1erePlage & ",B$9+1.5*(B$9-B$2))"
    [B8] = "=MAX(" & Nom1erePlage & ")"
    [B9] = "=QUARTILE(" & Nom1erePlage & ",3)"
    [B10] = "=NbAtypiquesInf(" & Nom1erePlage & ",B$4)"
    [B11] = "=NbAtypiquesSup(" & Nom1erePlage & ",B$7)"
    [B12] = "=COUNT(" & Nom1erePlage & ")"

   'mise en forme conditionnelle sur les 2 cellules des nombres atypiques : caractère blanc si valeur nulle
    [B10:B11].FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="0"
    [B10:B11].FormatConditions(1).Font.ColorIndex = 2

   'ajout de 2 noms relatifs pour mise en forme conditionnelle des mini et maxi
    ActiveWorkbook.Names.Add Name:=ActiveSheet.Name & "!NbAtypInf", RefersToR1C1:="=R10C"
    ActiveWorkbook.Names.Add Name:=ActiveSheet.Name & "!NbAtypSup", RefersToR1C1:="=R11C"

   'mise en forme conditionnelle des mini et maxi : en rouge s'ils sont atypiques
    [B3].FormatConditions.Add Type:=xlExpression, Formula1:="=NbAtypInf>0"
    [B3].FormatConditions(1).Font.ColorIndex = 3 'rouge
    [B8].FormatConditions.Add Type:=xlExpression, Formula1:="=NbAtypSup>0"
    [B8].FormatConditions(1).Font.ColorIndex = 3 'rouge

   'autres colonnes : recopie des formules vers la droite et sélection
    [B1:B12].Resize(, Donnees.Columns.Count).Select
    If Donnees.Columns.Count > 1 Then Selection.FillRight

   'mise en gras de la 1ere ligne et de la 1ere colonne du tableau
   Selection.Resize(1).Font.Bold = True 'gras sur la 1ere ligne
   Selection.Resize(, 1).Offset(, -1).Font.Bold = True 'gras sur la 1ere colonne
   [A:A].EntireColumn.AutoFit 'ajustement de la largeur de la 1ere colonne

   'quadrillage du tableau
    [A1:A12].Resize(, Donnees.Columns.Count + 1).Borders.LineStyle = xlContinuous

   'masquage du quadrillage de la feuille
    ActiveWindow.DisplayGridlines = False

   'exclusion de la sélection des lignes indiquant le nombre de points atypiques
   'pour preselection de la plage utile à la procédure CreerBoitesAMoustaches
    [B1:B9].Resize(, Donnees.Columns.Count).Select

End Sub

' ==================================================

Sub CreerBoitesAMoustaches(PlageStats As Range)

' ==================================================

'créer dans la feuille courante un graphique avec une ou plusieurs boîtes à moustaches
'selon les données définies dans la plage spécifiée devant contenir 6 lignes
'et autant de colonnes que de séries plus une
'ENTREE PlageStats : spécifie la plage à traiter (1ère ligne = nom des séries, autres lignes
'                    = descripteurs statistiques : q1, min, mediane, max, q3)
    Dim s As Integer
    Dim FeuilleActive As Worksheet, Graphique As Chart

    Set FeuilleActive = ActiveSheet
    Set Graphique = Charts.Add 'création d'un nouveau graphique
    With Graphique

        'La plage représente les résumés statistiques sur 6 lignes (dont les libellés en en-tête)
         .SetSourceData Source:=FeuilleActive.Range(PlageStats.Address), PlotBy:=xlRows   'données en ligne

        .ChartType = xlLineMarkers 'type : courbe
        .Legend.Delete 'suppression de la légende
        .PlotArea.Interior.ColorIndex = xlNone 'pas de couleur de fond
        For s = 1 To .SeriesCollection.Count
            With .SeriesCollection(s)
                .Border.LineStyle = xlNone 'pas de ligne entre séries
                .MarkerForegroundColorIndex = 1 'marques de couleur noire
                .MarkerBackgroundColorIndex = xlNone 'marques sans fond (pour médiane)
            End With
        Next s
        .SeriesCollection(1).MarkerStyle = xlNone   'pas de marque pour le 1er quartile
        .SeriesCollection(2).MarkerStyle = xlCircle 'rond noir pour le mini
        .SeriesCollection(3).MarkerStyle = xlDash   'trait horizontal noir pour moustache basse
        .SeriesCollection(4).MarkerStyle = xlDash   'trait horizontal noir pour la médiane
        .SeriesCollection(4).MarkerSize = 12 'avec une largeur plus grande que les autres
        .SeriesCollection(5).MarkerStyle = xlPlus   'croix noire pour la moyenne
        .SeriesCollection(6).MarkerStyle = xlDash   'trait horizontal noir pour moustache haute
        .SeriesCollection(7).MarkerStyle = xlCircle 'rond noir pour le maxi
        .SeriesCollection(8).MarkerStyle = xlNone   'pas de marque pour le 3eme quartile
        With .ChartGroups(1)
            .HasDropLines = False
            .HasHiLoLines = True 'affichage des lignes verticales
            .HasUpDownBars = True 'affichage des boîtes
            .GapWidth = 300
        End With
        .ChartArea.AutoScaleFont = False
        .Location Where:=xlLocationAsObject, Name:=FeuilleActive.Name
          'déplacement de la feuille graphique vers un objet dans la feuille initiale
          'ATTENTION : cette instruction doit être la dernière pour Graphique
    End With
   'repositionnement du graphique à gauche de la feuille et sous le tableau descriptif
    FeuilleActive.ChartObjects(1).Left = [$A$14].Left + [$A$14].Width / 2
    FeuilleActive.ChartObjects(1).Width = PlageStats.Width + [$A$14].Width / 2
    FeuilleActive.ChartObjects(1).Top = [$A$14].Top

End Sub

' ==================================================

Function PlageNumerique(Plage As Range) As Boolean

' ==================================================

'renvoie vrai si la plage spécifiée ne contient que des valeurs numériques
'(les cellules vides sont ignorées)
    Dim cell As Range, OK As Boolean
    OK = True
    For Each cell In Plage.Cells
        If Not (cell = "") Then
            If Not (Application.WorksheetFunction.IsNumber(cell)) Then
                OK = False
                Exit For
            End If
        End If
    Next
    PlageNumerique = OK

End Function

' ==================================================

Function PlageTextuelle(Plage As Range) As Boolean

' ==================================================

'renvoie vrai si la plage spécifiée ne contient que des valeurs textuelles
'(y compris valeurs numériques définies au formet "Texte" par Format / Cellule / Nombre)
    Dim cell As Range, OK As Boolean
    OK = True
    For Each cell In Plage.Cells
        If Not (Application.WorksheetFunction.IsText(cell) Or cell.NumberFormat = "@") Then
         'le format @ correspond au format "Texte" défini par Format / Cellule / Nombre
         'utilisable si les libellés des séries sont des numéros
            OK = False
            Exit For
        End If
    Next
    PlageTextuelle = OK

End Function

' ==================================================

Function ExisteFeuille(Nom) As Boolean

' ==================================================

'renvoie vrai si la feuille de nom spécifié existe dans le classeur
    Dim f As Worksheet, OK As Boolean
    OK = False
    For Each f In Worksheets
        If f.Name = Nom Then OK = True: Exit For
    Next
    ExisteFeuille = OK

End Function

' ==================================================

Function PlusPetiteValeurSuperieureA(Serie As Range, ByVal Limite As Double) As Variant

' ==================================================

'renvoie la valeur la plus petite de la série, qui est supérieure à la limite fixée
'ENTREE Serie : plage à traiter (valeurs numériques entières ou réelles)
'       Limite : valeur seuil
    Dim PlusPetit As Variant, Maxi As Variant 'même type que la série
    Dim Cellule As Variant, i As Integer

    i = 1: Cellule = Serie.Cells(1)
    Do While Not (Application.WorksheetFunction.IsNumber(Cellule) Or (Cellule = ""))
    'sauter les cellules non numériques (en-tete) ou vides
        i = i + 1: Cellule = Serie.Cells(i)
    Loop
    PlusPetit = Cellule: Maxi = Cellule
    Do While i < Serie.Cells.Count
        i = i + 1: Cellule = Serie.Cells(i)
        If Not Cellule = "" Then 'sauter les cellules vides
            If Cellule > Maxi Then
                Maxi = Cellule 'mise à jour du maximum
                If PlusPetit < Limite Then PlusPetit = Maxi
            End If
            If Cellule >= Limite Then
                If Cellule < PlusPetit Then PlusPetit = Cellule
            End If
        End If
    Loop
    PlusPetiteValeurSuperieureA = PlusPetit

End Function

' ==================================================

Function PlusGrandeValeurInferieureA(Serie As Range, ByVal Limite As Double) As Variant

' ==================================================

'renvoie la valeur la plus grande de la série, qui est inférieure à la limite fixée
'ENTREE Serie : plage à traiter (valeurs numériques entières ou réelles)
'       Limite : valeur seuil
    Dim PlusGrand As Variant, Mini As Variant 'même type que la série
    Dim Cellule As Variant, i As Integer

    i = 1: Cellule = Serie.Cells(1)
    Do While Not (Application.WorksheetFunction.IsNumber(Cellule) Or (Cellule = ""))
    'sauter les cellules non numériques (en-tete) ou vides
        i = i + 1: Cellule = Serie.Cells(i)
    Loop
    PlusGrand = Cellule: Mini = Cellule
    Do While i < Serie.Cells.Count
        i = i + 1: Cellule = Serie.Cells(i)
        If Not Cellule = "" Then 'sauter les cellules vides
            If Cellule < Mini Then
                Mini = Cellule 'mise à jour du Minimum
                If PlusGrand > Limite Then PlusGrand = Mini
            End If
            If Cellule <= Limite Then
                If Cellule > PlusGrand Then PlusGrand = Cellule
            End If
        End If
    Loop
    PlusGrandeValeurInferieureA = PlusGrand

End Function

' ==================================================

Function NbAtypiquesInf(Serie As Range, ByVal MoustacheInf As Double) As Integer

' ==================================================

'renvoie le nombre de points de la série inférieurs à la valeur de la moustache inférieure
'ENTREE Serie : plage à traiter (valeurs numériques entières ou réelles)
'       MoustacheInf : valeur de la moustache inférieure
    Dim NbPointsAtypiques As Integer
    Dim Cellule As Variant, i As Integer

    i = 1: Cellule = Serie.Cells(1)
    Do While Not (Application.WorksheetFunction.IsNumber(Cellule) Or (Cellule = ""))
    'sauter les cellules non numériques (en-tete) ou vides
        i = i + 1: Cellule = Serie.Cells(i)
    Loop
    NbPointsAtypiques = 0
    Do While i <= Serie.Cells.Count
        Cellule = Serie.Cells(i)
        If Not Cellule = "" Then 'sauter les cellules vides
            If Cellule < MoustacheInf Then
                NbPointsAtypiques = NbPointsAtypiques + 1
            End If
        End If
        i = i + 1
    Loop
    NbAtypiquesInf = NbPointsAtypiques

End Function

' ==================================================

Function NbAtypiquesSup(Serie As Range, ByVal MoustacheSup As Double) As Integer

' ==================================================

'renvoie le nombre de points de la série supérieurs à la valeur de la moustache supérieure
'ENTREE Serie : plage à traiter (valeurs numériques entières ou réelles)
'       MoustacheSup : valeur de la moustache supérieure
    Dim NbPointsAtypiques As Integer
    Dim Cellule As Variant, i As Integer

    i = 1: Cellule = Serie.Cells(1)
    Do While Not (Application.WorksheetFunction.IsNumber(Cellule) Or (Cellule = ""))
    'sauter les cellules non numériques (en-tete) ou vides
        i = i + 1: Cellule = Serie.Cells(i)
    Loop
    NbPointsAtypiques = 0
    Do While i <= Serie.Cells.Count
        Cellule = Serie.Cells(i)
        If Not Cellule = "" Then 'sauter les cellules vides
            If Cellule > MoustacheSup Then
                NbPointsAtypiques = NbPointsAtypiques + 1
            End If
        End If
        i = i + 1
    Loop
    NbAtypiquesSup = NbPointsAtypiques

End Function

' ==================================================


' === fin de fichier BOXPLOTS.TXT