Comment écrire des fonctions UDF base de données qui respectent la façon d'écrire les critères base de données de Excel ?

Le problème principal est de récupérer dans une variable array les valeurs du champ uniquement pour les enregistrements correspondants au critère passé à la fonction. Je me suis pas mal creusé la tête pour une solution somme toute assez simple.

Sur la base d'une itération sur le nombre d'enregistrements de la bdd :
- un range rBDD dont le nombre d'enregistrements augmente de 1 à chaque itération.
- la fonction Excel DCount permet de savoir si le nombre de valeurs numériques a augmenté entre 2 itérations
- la fonction Excel DSum permet par différence avec la somme de l'itération précédente de récupérer la valeur à considérer dans l'array.

Une fois que cette première étape est passée, il ne reste plus qu'à faire les calculs souhaités sur l'array.

Ci-dessous, un exemple avec la fonction BDCENTILE

J'avais bien lu ce fil vieux de 2007, mais je trouvais que l'on s'écartait trop de la philosophie des fonctions BD de Excel.

La fonction met 20 secondes (très long) pour une BDD de 10000 lignes, sur un Core 2 - 2.66. Si quelqu'un a mieux, je suis preneur

En espérant que cela serve avant que MS nous mette cela en natif

Code : Sélectionner tout - Visualiser dans une fenêtre à part
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