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
| Option Explicit
Option Base 1 'les arrays commencent à 1
Function BDCentile(BDD As Range, ByVal champ As Variant, critere As Range, Optional centile As Single = 0.5)
' vChamp variant pour être soit valeur, soit Range
' aValeur variant pour supporter le redim
Dim aValeur, vChamp As Variant
Dim rBDD As Range
Dim i, vCount, vTempCount, vNbLigneBDD, vNbColonneBDD, vPos As Long
Dim vSum, vTempSum, vN1P As Double
Dim j As Integer
' Analyse de la colonne a traiter et traduction en numero
' que lon ait passé une valeur numerique, une reference ou un nom de champ dans champ
If TypeName(champ) = "Range" Then
vChamp = champ.Value
Else
vChamp = champ
End If
If TypeName(vChamp) <> "String" And TypeName(vChamp) <> "Double" Then
BDCentile = CVErr(xlErrValue)
Return
Else
vNbLigneBDD = BDD.Rows.Count
vNbColonneBDD = BDD.Columns.Count
If TypeName(vChamp) = "Double" Then
vChamp = CInt(vChamp)
Else
'recherche du numero de la colonne
j = 0
Do
j = j + 1
Loop While j <= vNbColonneBDD And BDD.Cells(1, j).Value <> vChamp
vChamp = j
End If
If vChamp < 0 Or vChamp > vNbColonneBDD Then
BDCentile = CVErr(xlErrValue)
Return
End If
End If
' Recuperation des valeurs dans un vecteur
' pas trouvé plus simple pour appliquer nimporte quel critere bdd "a la Excel"
' On ajoute une ligne à rBDD à chaque itération
' Si le nombre de valeur a augmenté, on trouve la nouvelle valeur
' par différence entre la somme actuelle et la somme précédente
ReDim aValeur(1 To vNbLigneBDD - 1)
vCount = 0
vSum = 0
For i = 2 To vNbLigneBDD
Set rBDD = Range(BDD.Cells(1, 1), BDD.Cells(i, vNbColonneBDD))
vTempCount = Application.WorksheetFunction.DCount(rBDD, vChamp, critere)
If vCount = vTempCount - 1 Then
vCount = vTempCount
vTempSum = Application.WorksheetFunction.DSum(rBDD, vChamp, critere)
aValeur(vCount) = vTempSum - vSum
vSum = vTempSum
End If
Next
If vCount = 0 Then
BDCentile = CVErr(xlErrValue)
Return
End If
ReDim Preserve aValeur(1 To vCount)
' calcul du centile
' tri de aValeur puis
' si (n-1) x p entier, aValeur((n-1) x p + 1)
' sinon, interpolation entre aValeur(int((n-1) x p + 1) et aValeur(int((n-1) x p + 2)
aValeur = BubbleSort(aValeur)
vN1P = (vCount - 1) * centile
If Int(vN1P) = vN1P Then
BDCentile = aValeur(vN1P + 1)
Else
vPos = Int(vN1P + 1)
vN1P = vPos - vN1P
BDCentile = vN1P * aValeur(vPos) + (1 - vN1P) * aValeur(vPos + 1)
End If
End Function
Function BubbleSort(aToSort As Variant, Optional sortAscending As Boolean = True) As Variant
Dim vChange As Boolean
Dim i As Long
Dim vSwap As Variant
Do
vChange = False
For i = LBound(aToSort) To UBound(aToSort) - 1
If (aToSort(i) > aToSort(i + 1) And sortAscending) _
Or (aToSort(i) < aToSort(i + 1) And Not sortAscending) Then
vSwap = aToSort(i)
aToSort(i) = aToSort(i + 1)
aToSort(i + 1) = vSwap
vChange = True
End If
Next i
Loop Until Not vChange
BubbleSort = aToSort
End Function |
Partager