On a souvent besoin de trouver la valeur mini ou maxi d’un tableau de valeurs numériques mais plus rarement la 10ème plus petite valeur, la 10 000 000ème… Je vous présente ici une implémentation en VBA d’un algorithme tout en un, d’une rare simplicité qui sélectionne en une fraction de seconde la valeur du rang désiré.
L’algorithme
Cet algorithme, tout comme le célèbre quicksort, est basé sur le partitionnement du tableau de valeurs. Il est dû à Zabrodsky qui améliora sensiblement un algo proposé par N. Wirth (1976).
Voici mon implémentation en VBA de l’algorithme de Zabrodsky dans le cas d’un tableau d’entiers long:
'http://dhost.info/zabrodskyvlada/3alg.html
'implementation in VBA by Philben - v1.0
Dim x As Long, tmp As Long
Dim i As Long, j As Long, l As Long, r As Long
l = LBound(a)
r = UBound(a)
While l < r
x = a(k)
i = l
j = r
Do Until j < k Or k < i
While a(i) < x: i = i + 1: Wend
While x < a(j): j = j - 1: Wend
tmp = a(i): a(i) = a(j): a(j) = tmp
i = i + 1
j = j - 1
Loop
If j < k Then l = i
If k < i Then r = j
Wend
KthSmallest = a(k)
End Function
Il existe de nombreux autres algorithmes (selectSmallest in Numerical Recipes, findElementAtRank, quickSelect, …) et vous trouverez ici une publication sur le sujet.
Paramètres de la fonction
Le premier paramètre est le tableau des valeurs et le deuxième (k) est le rang pour lequel on souhaite connaître la valeur associée.
Par exemple, le minimum d’un tableau est recherché par k = 1 si l’indice le plus faible du tableau est 1, et plus généralement avec k = LBound(MonTableau).
Le maximum du tableau est recherché avec k = UBound(MonTableau) et la 10ème plus petite valeur avec k = 10 (si LBound(MonTableau)=1).
Exemple
Soit un tableau de base 1 contenant les valeurs 5, 3, 7, 1, 5.
L’algo retournera :
- 1 pour k = 1
- 3 pour k = 2
- 5 pour k = 3 (médiane des valeurs) et k = 4
- 7 pour k = 5
Comment faire si mon tableau est de type Double par exemple ?
Il suffit de modifier certains types de variable en DOUBLE et le type retourné par la fonction :
Dim x As DOUBLE, tmp As DOUBLE
...
Vérification de l’implémentation en VBA
La fonction suivante permet de vérifier succinctement que l’algorithme remplit bien sa mission.
Vous pouvez modifier à votre guise les constantes cMinIndice, cMaxIndice.
Pour l’utiliser, copier l’ensemble du code dans un module VBA, placer le focus dans la fonction puis appuyer sur ‘F5‘ pour l’exécuter. Les résultats s’affichent dans la fenêtre ‘Exécution’ (Ctrl+G)
'Plus le nombre d'indices est élevé (cMaxIndice - cMinIndice + 1), plus la fonction prend du temps...
'Pour 1000 indices par exemple, elle teste alors 4000 tableaux de 1000 indices...
'Tester aussi bien un nombre d'indices pair et impair
Const cMinIndice As Long = 1 'Indice mini du tableau (= Ã l'indice mini)
Const cMaxIndice As Long = 1000
Dim a() As Long, aBackup() As Long, n As Long, r As Long
ReDim a(cMinIndice To cMaxIndice)
ReDim aBackup(cMinIndice To cMaxIndice)
'Test n°1 : Tableau de valeurs croissantes
'Chaque indice correspond à sa valeur (a(1)=1, a(2)=2,...)
'La Nième valeur est égale au Nième indice
For n = cMinIndice To cMaxIndice: a(n) = n: Next n
aBackup = a 'un tableau dynamique peut être copié comme une variable simple contrairement à un tableau statique
For n = cMinIndice To cMaxIndice
r = KthSmallest(a, n)
If r <> n Then Debug.Print "Test n°1", "Erreur pour n=", n, "Résultat=", r
a = aBackup
Next n
'Test n°2 : Tableau de valeurs décroissantes
'Chaque indice correspond à sa valeur opposée (a(cMinIndice)=cMaxIndice, a(cMinIndice+1)=cMaxIndice-1,...)
'La Nième valeur est égale au Nième indice
For n = cMinIndice To cMaxIndice: a(n) = cMaxIndice - n + cMinIndice: Next n
aBackup = a
For n = cMinIndice To cMaxIndice
r = KthSmallest(a, n)
If r <> n Then Debug.Print "Test n°2", "Erreur pour n=", n, "Résultat=", r
a = aBackup
Next n
'Test n°3 : Tableau de valeurs identiques sauf une
'Toutes les valeurs sauf une (=1) sont égales à 0
'Tous les résultats sont égaux à 0 sauf pour le dernier indice (=1)
Randomize
For n = cMinIndice To cMaxIndice: a(n) = 0: Next n
aBackup = a
For n = cMinIndice To cMaxIndice
a(Int((cMaxIndice - cMinIndice + 1) * Rnd() + cMinIndice)) = 1
r = KthSmallest(a, n)
If (n < cMaxIndice And r <> 0) Or (n = cMaxIndice And r <> 1) Then Debug.Print "Test n°3", "Erreur pour n =", n, "Résultat =", r
a = aBackup
Next n
'Test n°4 : Tableau de valeurs identiques sauf une
'Toutes les valeurs sauf une (=0) sont égales à 1
'Tous les résultats sont égaux à 1 sauf pour le premier indice (=0)
For n = cMinIndice To cMaxIndice: a(n) = 1: Next n
aBackup = a
For n = cMinIndice To cMaxIndice
a(Int((cMaxIndice - cMinIndice + 1) * Rnd() + cMinIndice)) = 0
r = KthSmallest(a, n)
If (n > cMinIndice And r <> 1) Or (n = cMinIndice And r <> 0) Then Debug.Print "Test n°4", "Erreur pour n =", n, "Résultat =", r
a = aBackup
Next n
Debug.Print "*** fin ***"
End Function
Performance de l’algorithme
La fonction suivante permet de tester la performance de l’algorithme sur un tableau de 10 000 000 de valeurs !
Si vous souhaitez réduire la taille du tableau, il faut alors jouer sur la constante ‘cMaxIndice’. Pour modifier le rang de la valeur à trouver, modifier la constante ‘cNiemeValeur’ qui doit être comprise obligatoirement entre 1 et ‘cMaxIndice’
Pour déterminer la durée de traitement de l’algorithme, on utilise l’API timeGetTime. Il faut donc ajouter la ligne suivante en tête du module VBA :
Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Copier l’ensemble du code suivant dans le module VBA où l’API est déclarée, placer le focus dans la fonction puis appuyer sur ‘F5‘ pour l’exécuter. Les résultats s’affichent dans la fenêtre ‘Exécution’ (Ctrl+G)
Const cMaxIndice As Long = 10 ^ 7 'Nombre maximum d'indices du tableau (10^7 = 10 000 000)
Const cMaxValeur As Long = 10 ^ 8 'Valeur maxi
Const cNiemeValeur As Long = 10 ^ 3 'Nième valeur retournée doit être comprise entre 1 <= cNiemeValeur <= cMaxIndice
Dim a() As Long, i As Long, r As Long, t As Long
Dim s As String
Randomize
ReDim a(1 To cMaxIndice)
For i = 1 To cMaxIndice
a(i) = Rnd() * cMaxValeur
Next i
Debug.Print "Départ..."
t = timeGetTime
r = KthSmallest(a, cNiemeValeur)
'r = FindMini(a) 'recherche seulement la valeur mini
t = timeGetTime - t
s = Switch(cNiemeValeur = 1, "plus petite valeur est : ", _
cNiemeValeur < cMaxIndice, cNiemeValeur & "ème plus petite valeur est : ", _
True, "plus grande valeur est : ")
Debug.Print vbTab & "La " & s & r, "- Temps écoulé : " & t & " ms", vbNewLine & "Fin"
End Function
Avec mon système et ces paramètres, l’algorithme retourne le résultat du 1000ème rang entre 250ms et 750ms (plus ou moins de swap et de comparaisons selon les nombres aléatoires générés).
En paramétrant la constante ‘cNiemeValeur’ à 1 pour obtenir la plus petite valeur du tableau, vous pouvez comparer la performance de l’algorithme avec la fonction suivante :
Dim i As Long, k As Long, x As Long
k = LBound(a)
x = a(k)
For i = k + 1 To UBound(a)
If a(i) < x Then x = a(i)
Next i
FindMini = x
End Function
Comme vous pouvez le constater, les temps sont très proches dans ce cas de figure (temps en O(N)) et la recherche de la valeur maximale du tableau est tout aussi rapide…
Points faibles de l’algorithme
L’ordre des éléments du tableau d’origine est modifié. Si nécessaire, travailler avec une copie du tableau ou utiliser l’algorithme quickselect.
De plus, lorsque toutes les valeurs du tableau sont identiques, le temps d’exécution devient alors beaucoup plus long.
@+
Philippe