1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
|
Option Compare Database
Option Explicit
' Renvoie la médiane d'une distribution (voir la fonction PourcentileDom pour + d'infos)
Public Function MedianeDom(ByVal sExpression As String, _
ByVal sDomaine As String, _
Optional ByVal sCritere As String = vbNullString, _
Optional ByVal bNullAsZero As Boolean = False, _
Optional ByVal bMsgBoxErr As Boolean = True) As Double
MedianeDom = fPourcentileDom(50, sExpression, sDomaine, sCritere, bNullAsZero, bMsgBoxErr)
End Function
'************************************************************************************************
'* Fonction : fPourcentileDom
'* Auteur : PhilBen
'* Version : 1.01
'* Publication : 22/07/2006 (www.developpez.com)
'* Dépendances : fPourcentileDom -> IsStatDomErr -> StatExpressionErr
'* Objet : Renvoie le x-ième pourcentile des valeurs d'une distribution.
'* Le plus connu des pourcentiles est la médiane ou 2ème quartile (50e pourcentile)
'* qui est la valeur correspondante à la position centrale de la distribution.
'* Permet par exemple de définir un seuil d'acceptation ou de sélection de valeurs.
'* Remarques : - La valeur numérique retournée peut être interpolée si le pourcentile
'* demandé ne correspond pas un enregistrement du domaine étudié.
'* - Le 1er quartile correspond à un pourcentile de 25, le 3ème à 75.
'* Paramètres : - dPourcentile : Valeur (type Double) du pourcentile demandé [0,0% à 100,0%]
'* - sExpression : Identifiant obligatoire de la distribution étudiée
'* - sDomaine : Identifiant obligatoire du nom de la table ou de la requête
'* qui porte les enregistrements du domaine étudié;
'* - sCritere : Expression facultative permettant de restreindre l'étendue
'* du domaine étudié (équivalent à l'argument de la clause WHERE
'* d'une requête SQL)
'* - bNullAsZero : Indique si la fonction doit considérer les valeurs nulles
'* comme égales à zéro (True) ou si elle n'en tient pas compte
'* (False, par défaut)
'* - bMsgBoxErr : Valeur boléenne facultative (Vrai par défaut) indiquant
'* si la fonction affiche ou non un message en cas d'erreur
'* Retour : Renvoie la valeur (type Double) du pourcentile demandé
'* Exemple : MsgBox PourcentileDom(95.0, "MonChampEtudié", "NomDeMaTable")
'************************************************************************************************
Public Function fPourcentileDom(ByVal dPourcentile As Double, ByVal sExpression As String, _
ByVal sDomaine As String, Optional ByVal sCritere As String = vbNullString, _
Optional ByVal bNullAsZero As Boolean = False, _
Optional ByVal bMsgBoxErr As Boolean = True) As Double
On Error GoTo PCDErr
Dim oDb As DAO.Database
Dim oRs As DAO.Recordset
Dim dPosition As Double, dRatio As Double, dResult As Double
Dim sSql As String, sTmpCrit As String, sMsgErr As String
If Not IsStatDomErr(sMsgErr, "Pourcentile", sDomaine, sExpression) Then
If dPourcentile < 0 Or dPourcentile > 100 Then
sMsgErr = "Le <Pourcentile> doit être dans l'intervalle [0,0% à 100,0%]..."
GoTo fin
End If
If Not sExpression Like "[[]*[]]" Then sExpression = "[" & Trim$(sExpression) & "]"
If Not sDomaine Like "[[]*[]]" Then sDomaine = "[" & Trim$(sDomaine) & "]"
sSql = "SELECT " & sExpression & " FROM " & sDomaine
sCritere = Trim$(sCritere)
If Not bNullAsZero Then
sTmpCrit = "(" & sExpression & ") Is Not Null"
sCritere = IIf(Len(sCritere) > 0, sCritere & " AND " & sTmpCrit, sTmpCrit)
End If
If Len(sCritere) > 0 Then
sSql = sSql & " WHERE " & sCritere
End If
sSql = sSql & " ORDER BY " & sExpression & ";"
Set oDb = CurrentDb
Set oRs = oDb.OpenRecordset(sSql, dbOpenSnapshot)
If Not oRs.EOF Then
Select Case oRs.Fields(0).Type
Case dbByte, dbInteger, dbLong, dbFloat, dbSingle, dbDouble
oRs.MoveLast 'Nécessaire pour le calcul de RecordCount
If oRs.RecordCount > 1 Then
dPosition = dPourcentile * (oRs.RecordCount - 1) / 100
dRatio = dPosition - Int(dPosition)
oRs.Move (Int(dPosition) - oRs.RecordCount + 1)
dResult = Nz(oRs.Fields(0))
If dRatio > 0 Then
oRs.MoveNext
dResult = dResult + (Nz(oRs.Fields(0)) - dResult) * dRatio
End If
fPourcentileDom = dResult
Else
fPourcentileDom = Nz(oRs.Fields(0))
End If
Case Else
sMsgErr = "<Expression> doit retourner une valeur numérique..."
End Select
Else
sMsgErr = "Aucun enregistrement retourné par le domaine..."
End If
End If
fin:
Set oRs = Nothing
Set oDb = Nothing
If bMsgBoxErr And Len(sMsgErr) > 0 Then
MsgBox sMsgErr, vbExclamation, "fPourcentileDom"
End If
Exit Function
PCDErr:
sMsgErr = "Erreur n°" & Err.Number & vbCrLf & "Description :" & Err.Description
Resume fin
End Function
' Vérifie sommairement les paramètres de la fonction de statistiques
Private Function IsStatDomErr(sMsgErr As String, sNomFunc As String, _
sDomaine As String, sExpression1 As String, _
Optional sExpression2 As String = vbNullString) As Boolean
sMsgErr = vbNullString
If Len(Trim$(sDomaine)) = 0 Then
sMsgErr = "<Domaine> ne peut être vide..."
Else
sMsgErr = StatExpressionErr(sNomFunc, Trim$(sExpression1))
If Len(sMsgErr) = 0 And sExpression2 <> vbNullString Then
sMsgErr = StatExpressionErr(sNomFunc, Trim$(sExpression2))
End If
End If
If Len(sMsgErr) > 0 Then IsStatDomErr = True
End Function
' Vérifie sommairement les expressions
Private Function StatExpressionErr(sNomFunc As String, sExpression As String) As String
If Len(sExpression) = 0 Then
StatExpressionErr = "<Expression> ne peut être vide..."
ElseIf sExpression = "*" Or InStr(1, sExpression, ".*", vbBinaryCompare) > 0 Then
StatExpressionErr = "Le " & sNomFunc & " ne peut être calculé sur l'ensemble des colonnes (*)..."
ElseIf InStr(1, sExpression, ",", vbBinaryCompare) > 0 Then
StatExpressionErr = "<Expression> ne doit pas retourner plus d'un champ..."
ElseIf InStr(1, sExpression, " AS ", vbTextCompare) > 0 Then
StatExpressionErr = "Le champ de <Expression> ne doit pas être aliasé..."
End If
End Function |
Partager