VBA Excel - Nombres premiers
- Introduction
- Définition
- Fonction
- Tous les nombres premiers : algorithme
- Code de la fonction
- Code d'appel
- Amélioration, optimisation d'un algorithme/code
- I- Avec variables tableau
- Première implémentation : l'algorithme naïf
- Seconde implémentation : Ainsi naquit Erathostène
- Troisième implémentation : Inutile de repasser 3 fois tes caleçons!
- Quatrième implémentation : Ce n'est pas la peine de ReDim un max
- Cinquième implémentation : Le fermier dans son pré
- Autre modèle : avec Mod, Modulo
- II- Avec Collection
- I- Avec variables tableau
- Fichiers à télécharger
Introduction
Pour trouver tous les nombres premiers, nous allons utiliser la méthode du crible d'Eratosthène. Cela consiste à boucler sur tous les nombres de 2 à n, de vérifier si le nombre "en cours" est un multiple. S'il ne l'est pas, il s'agit d'un nombre premier.
Lien wikipédia.
Définition
Un nombre premier est un entier naturel qui admet exactement deux diviseurs distincts entiers et positifs (qui sont alors 1 et lui-même).
Fonction
Code appelant
Sub Appel() Debug.Print EstPremier(31) Debug.Print EstPremier(42) Debug.Print EstPremier(Cells(2, 3)) End Sub
Code de la fonction
Function EstPremier(Nb As Integer) As Boolean Dim i As Long If Nb = 1 Or Nb = 0 Then Exit Function For i = 2 To Sqr(Nb) If Nb Mod i = 0 Then Exit Function Next i EstPremier = True End Function
Nota : Cette fonction personnalisée peut être utilisée comme formule de feuille de calcul. Pour cela, saisir dans la feuille, par exemple :
=EstPremier(A1)
Tous les nombres premiers : algorithme
Pour réaliser ceci, on écrit la liste de tous les nombres jusqu'à NbreMax.
- On élimine 1.
- On souligne 2 et on élimine tous les multiples de 2.
- Puis on fait de même avec 3.
- On choisit alors le plus petit nombre non souligné et non éliminé ici 5,
- On élimine tous ses multiples.
- On réitère le procédé jusqu'à la partie entière de la racine de n.
Les nombres non éliminés sont les nombres premiers jusqu'à n.
Code de la fonction
Le choix du type de cette fonction est due au fait que je souhaitais voir les erreurs apparaitre comme message à l'utilisateur. Nous pourrions facilement la "bricoler" pour que cette fonction nous renvoie un nombre de type Integer ou Long...
Pour des raisons de lenteur de ce code, nous allons également nous limiter aux 1500 premiers nombres premiers...
Function NbPremiers_Eratosthène(Rang As Long) As Variant 'Détermination du nième nombre premier méthode du crible d'Eratosthène Dim i As Long, j As Long, k As Long, NbreMax As Long, est_premier(), Flag As Boolean If Rang >= 1 And Rang <= 1500 Then ReDim Preserve est_premier(Rang) k = 0 NbreMax = 20 * Rang 'suffit pour un rang < 1500 Flag = True For i = 2 To NbreMax For j = 2 To i If j = i Then Exit For If i Mod j = 0 Then Flag = False: Exit For Next If Flag = True Then If i = 2 Then est_premier(k) = 1 k = k + 1 Else est_premier(k) = i k = k + 1 End If Else Flag = True End If If k = Rang Then Exit For Next i NbPremiers_Eratosthène = est_premier(Rang - 1) Else NbPremiers_Eratosthène = "Rang trop grand ou trop petit (compris entre 1 et 1500 inclus)." End If End Function
Code d'appel
Nous avons ici deux possibilités :
Nième nombre premier
Sub Test() 'Pour obtenir le 499ième Nombre premier : MsgBox NbPremiers_Eratosthène(499) End Sub
Liste des 99 premiers nombres premiers
Sub ListeNbPrems() 'Pour obtenir la liste des 99 1ers nombres premiers : Dim i As Long, Msg As String, Tb(98) For i = 1 To 99 Tb(i - 1) = NbPremiers_Eratosthène(i) Next i MsgBox Tb(0) & " " & Tb(1) & " " & Tb(2) & " ... " & Tb(UBound(Tb)) End Sub
Amélioration, optimisation d'un algorithme/code
Il est bien entendu que nous ne nous contenterons pas de trouver les 99 premiers nombres premiers.
L'optimisation n'aurait, dans ce cas, pas lieu d'être.
Le but est de trouver les nombres premiers avec une borne supérieure N très grande, dans un minimum de temps, et une parfaite "stabilité", tout en sachant que :
- ce sujet n'a d'autre intérêt que celui d'exercice,
- Visual Basic ne battra jamais de records, ni ne trouvera le premier nombre premier inconnu à ce jour,
- il ne s'agit pas ici d'une course contre le temps, les résultats donnés le sont uniquement à titre de comparaison.
Note : Pour l'ensemble des codes de la 1ère partie, nous utiliserons la procédure d'appel suivante :
Sub test_Crible() Dim Tb() As Long, N As Long, T As Single T = Timer N = 10000 Tb = Liste_Premiers(N) Debug.Print "Pour N = " & N & ", durée : " & Timer - T & " seconde, " & _ UBound(Tb) + 1 & " nombres premiers, de " & _ Tb(LBound(Tb)) & " à " & _ Tb(UBound(Tb)) End Sub
I- Avec variables tableau
Première implémentation : l'algorithme naïf
Algo :
- Un tableau dimensionné à N dont tous les éléments sont mis à false
- On part du chiffre 2 et on met à True tous ses multiples, jusqu'à N (ses multiples correspondront très exactement à leur index dans le tableau)
- On passe au suivant et refait la même chose avec ses multiples
Comment cela peut donc bien se traduire en code VBA...
L'algorithme suivant est dit "naïf" car non-optimisé.
Function Liste_Premiers(Max As Long) As Long() Dim Temp() As Boolean, Liste() As Long, cpt As Long Dim i As Long, j As Long ReDim Temp(Max) 'Ici, tous les items de Temp sont False 'double boucle For i = 2 To Max For j = i * i To Max Step i 'ici j est le multiple d'un nombre qui lui est inférieur '==> j n'est donc pas premier Temp(j) = True Next Next i 'restitution For i = 2 To Max If Temp(i) = False Then ReDim Preserve Liste(cpt) Liste(cpt) = i cpt = cpt + 1 End If Next i Liste_Premiers = Liste End Function
Résultat pour N = 10 000 : durée : 0 seconde, 1229 nombres premiers, de 2 à 9973
Mais...
Ce code ne peut pas fonctionner sur des N trops grands.
j = i * i entrainant un dépassement de capacité.
Optimisons...
Seconde implémentation : Ainsi naquit Erathostène
Pour ces deux raisons :
- accélérer le code,
- augmenter la taille de N
il faut :
- uniquement tester les impairs premiers déjà trouvés en tant que diviseurs
- en se limitant à la racine carrée de n
Cela va nous donner :
- 1 boucle sur les pairs (pour les éliminer),
- 1 double boucle réduite (de 1 à MAX, on passe à : de 1 à Sqr(MAX))
- 1 boucle de restitution
Le code devient donc :
Function Liste_Premiers(Max As Long) As Long() Dim Temp() As Boolean, Liste() As Long, cpt As Long, racine As Long Dim i As Long, j As Long ReDim Temp(Max) 'Ici, tous les items de Temp sont False 'pairs éliminés (hormis 2) : For i = 4 To Max Step 2 Temp(i) = True Next 'double boucle sur impairs ET jusqu'à racine carrée de MAX racine = Sqr(Max) For i = 3 To racine Step 2 For j = i * i To Max Step i 'ici j est le multiple d'un nombre qui lui est inférieur '==> j n'est donc pas premier Temp(j) = True Next Next i 'restitution For i = 2 To Max If Temp(i) = False Then ReDim Preserve Liste(cpt) Liste(cpt) = i cpt = cpt + 1 End If Next i Liste_Premiers = Liste End Function
A partir de maintenant, nous allons pouvoir tester sur de plus grands nombres. Arbitrairement, choisissons 8 000 000.
Dans la Sub initiale test, remplaçons donc N = 10000 par N = 8000000
Résultat :
durée : 1,832031 seconde, 539777 nombres premiers, de 2 à 7999993
Troisième implémentation : Inutile de repasser 3 fois tes caleçons!
La réflexion suivante va être d'éliminer encore certaines valeurs.
Dans la double boucle, For i = 3 To racine Step 2, on se rends compte, à l'analyse, que l'on passe et repasse sur des nombres déjà traités.
Il n'est pas nécessaire, à titre d'exemple, de traiter les multiples de 9 dans la boucle For j, sachant qu'ils ont déjà été traités dans la boucle For j = 3 * 3 To...
Éliminons les.
Comment?
Juste ajouter un test If Temp(i) = False Then, comme ceci :
Function Liste_Premiers(Max As Long) As Long() Dim Temp() As Boolean, Liste() As Long, cpt As Long, racine As Long Dim i As Long, j As Long 'liste des nombres de 1 à Max + attribution du False ReDim Temp(2 To Max) 'boucle nombres pairs > 2 For i = 4 To Max Step 2 Temp(i) = True Next 'double boucle racine = Sqr(Max) For i = 3 To racine Step 2 If Temp(i) = False Then 'si i n'est pas le multiple d'un nombre inférieur For j = i * i To Max Step i 'ici j est le multiple d'un nombre inférieur à j '==> j n'est donc pas premier Temp(j) = True Next End If Next i 'restitution For i = 2 To Max If Temp(i) = False Then ReDim Preserve Liste(cpt) Liste(cpt) = i cpt = cpt + 1 End If Next i Liste_Premiers = Liste End Function
Les résultats :
Pour N = 8000000, avec Crible Tableau, durée : 1,216797 seconde, 539777 nombres premiers trouvés.
Quatrième implémentation : Ce n'est pas la peine de ReDim un max
Nous avons trois boucles :
- Elimination des pairs
- double boucle optimisée précédemment
- une boucle de restitution.
Comment réduire le temps d'exécution.
Ici, il faut faire appel à l'optimisation d'un code VBA pur et simple.
Dans la boucle de restitution, on ReDim un tableau à de nombreuses reprises (plus de 500000 fois).
Nous allons donc le dimensionner avant pour le redimensionner après son alimentation.
Le code devient donc :
Function Liste_Premiers(MAX As Long) As Long() Dim Temp() As Boolean, Liste() As Long, cpt As Long, racine As Long Dim i As Long, j As Long ReDim Temp(2 To MAX) 'Dimensionnement du tableau des résultats ReDim Liste(MAX / 2) 'boucle des pairs For i = 4 To MAX Step 2 Temp(i) = True Next 'double boucle racine = Sqr(MAX) For i = 3 To racine Step 2 If Temp(i) = False Then For j = i * i To MAX Step i Temp(j) = True Next End If Next i 'restitution For i = 2 To MAX If Temp(i) = False Then Liste(cpt) = i cpt = cpt + 1 End If Next i 'redimensionnement final ReDim Preserve Liste(cpt - 1) Liste_Premiers = Liste End Function
Résultats pour N = 8 000 000 :
durée : 0,7578125 seconde, 539777 nombres premiers, de 2 à 7999993
Cinquième implémentation : Le fermier dans son pré
Pouvons nous encore gagner en temps d'exécution?
Nous avons toujours 3 boucles. N'y a t'il pas moyen de s'en passer?
Analogie :
Le fermier voisin possède un champs de 3 hectares remplit de choux rouges et blancs.
Lorsqu'il est amené à compter ses choux rouges, je ne le vois pas arracher ses choux blancs pour après refaire le même parcours en comptant ses choux rouges!
Revenons en à nos nombres pairs.
Nous avons compris qu'il fallait les éviter pour ne pas avoir à "passer" la double boucle sur tous les nombres.
Plutôt que de les éviter, supprimons les de l'équation. Ignorons les dans la boucle de restitution!
Grâce à cela, nous évitons une boucle (la première) et réduisons la dernière boucle dite de restitution!
Le code :
Function Liste_Premiers(Max As Long) As Long() Dim Temp() As Boolean, Liste() As Long, cpt As Long, racine As Long Dim i As Long, j As Long ReDim Temp(2 To Max) ReDim Liste(Max \ 2) 'double boucle racine = Sqr(Max) For i = 3 To racine Step 2 If Temp(i) = False Then For j = i * i To Max Step i Temp(j) = True Next End If Next i 'restitution Liste(0) = 2 For i = 3 To Max Step 2 If Temp(i) = False Then cpt = cpt + 1 Liste(cpt) = i End If Next i ReDim Preserve Liste(cpt) Liste_Premiers = Liste End Function
Résultats pour N = 8 000 000 :
durée : 0,5 seconde, 539777 nombres premiers, de 2 à 7999993
Autre modèle : avec Mod, Modulo
L'utilisation de Mod sera forcément plus lente.
Qu'à cela ne tienne, testons !
Nous utiliserons 1 000 000 pour tester.
Voici le code optimisé par Marc-L (développez.com) :
Sub DemoMod1NombresPremiers() Dim T!, d&, NP&(), N&, R#, c&, L& T! = Timer d& = 1000000 ReDim NP(d \ 2, 0): NP(0, 0) = 2 For N = 3 To d Step 2 R# = Sqr(N) For c& = 0 To L& If N Mod NP(c, 0) Then If NP(c, 0) > R Then L = L + 1: NP(L, 0) = N: Exit For Else Exit For End If Next Next Debug.Print "Modulo1 : "; Format(Timer - T, "0.000s"), L + 1 End Sub
Le résultat :
Modulo1 pour : 1 000 000 trouve 78 497 solutions en : 1,422s
Le modulo est donc à la traîne par rapport au crible.
II- Avec Collection
En poussant les tests, on se rends compte que le dernier code de crible nous permet de traiter les nombres premiers jusqu'à de grands nombres (pour Excel bien sur !).
Par exemple, nous obtenons un résultat pour N = 100 000 000, et cela, en un temps "relativement acceptable" :
Pour N = 100 000 000, avec Crible Tableau, durée : 6,81 seconde, 5 761 455 nombres premiers trouvés.
En poussant plus loin, néanmoins, on se heurte à deux problèmes :
- la stabilité : lors de l'exécution du code, il arrive que VBA ne réponde plus,
- la capacité mémoire de l'ordinateur.
Sur le mien, en tentant N = 150 000 000, le code bloque sur la ligne ReDim Liste(MAX / 2) pour une erreur d'exécution 7. Mémoire insuffisante.
Il en va de même pour notre tableau de Boolean Temp() qui lui bloque un peu plus tard...
Comment pallier cela, quitte à perdre de la rapidité?
La Collection est la solution.
Pour aller plus haut ! :
On reprend donc le dernier code de crible en remplaçant la variable tableau Liste par une collection : NBP.
Nous perdrons en rapidité, mais gagnerons en amplitude.
Remarque : Sub et non plus Function.
Sub NBP_Collection_1() Dim Temp() As Boolean, NBP As New Collection Dim racine As Long, Max As Long, i As Long, j As Long Dim T As Single Max = 25000000 T = Timer ReDim Temp(2 To Max) NBP.Add 2 'double boucle racine = Sqr(Max) For i = 3 To racine Step 2 If Temp(i) = False Then For j = i * i To Max Step i Temp(j) = True Next End If Next i 'restitution For i = 3 To Max Step 2 If Temp(i) = False Then NBP.Add i Next i T = Timer - T Debug.Print "Pour N = " & Format(Max, "#,##0") & ", avec Crible Collection, durée : " & Format(T, "0.000s") & " seconde, " & _ Format(NBP.Count, "#,##0") & " nombres premiers trouvés." End Sub
Résultats :
Pour N = 150 000 000, avec Crible Collection, durée : 15,213s seconde, 8 445 858 nombres premiers trouvés.
Pour N = 200 000 000, avec Crible Collection, durée : 20,426s seconde, 11 080 599 nombres premiers trouvés.
Pour N = 250 000 000, avec Crible Collection, durée : 30,656s seconde, 14 860 683 nombres premiers trouvés.
Au delà, le problème de mémoire insuffisante se pose toujours pour le dimensionnement de la variable Temp() As Boolean.
Collection 2ème essai : Naïveté quand tu nous tiens...
Si, au lieu d'éliminer les "non premiers", on se contentait de garder les "premiers".
L'avantage de la collection ici réside dans l'utilisation de sa clé.
Si une même clé est utilisée deux fois, cela génère une erreur.
En annulant le gestionnaire d'erreur, on fait en sorte que cette seconde "entrée" ne soit pas enregistrée.
Ainsi :
On Error Resume Next maColl.Add 3, "cle" maColl.Add 9, "cle"
aura pour effet de ne stocker que 3 dans la collection.
Il nous faut donc imposer la même clé pour tous les multiples de 3, une autre clé pour tous les multiples de 5, une autre clé pour tous les multiples de 7, etc...
Pour cela, il nous faut une double boucle de création de clé et utiliser Mod (que l'on sait lent).
Sub Avec_Collection() Dim NbPrems As New Collection Dim i&, T!, S&, N& N = 1000000 S = Sqr(N) T = Timer NbPrems.Add 2, "2" For i = 3 To N Step 2 On Error Resume Next NbPrems.Add i, Cle(i, S) Next T = Timer - T Debug.Print "Pour N = " & Format(N, "#,##0") & ", avec Crible Collection, durée : " & Format(T, "0.000s") & " seconde, " & _ Format(NbPrems.Count, "#,##0") & " nombres premiers trouvés." End Sub Sub Avec_Dico() Dim d As Object Dim i&, T!, S&, N&, c$ Set d = CreateObject("Scripting.Dictionary") N = 1000000 S = Sqr(N) T = Timer d.Add "2", 2 For i = 3 To N Step 2 c = Cle(i, S) If Not d.Exists(c) Then d.Add c, i Next Debug.Print "dico " & Timer - T & " " & d.Count End Sub Function Cle(Nb As Long, Tot As Long) As String Dim i&, T! For i = 3 To Tot Step 2 'abandonné car plus lent que Mod : 'If Nb / i = Nb \ i Then Cle = i: Exit Function If Nb Mod i = 0 Then Cle = i Exit Function End If Next Cle = Nb End Function
Les résultats :
Pour N = 1 000 000, avec Collection, durée : 4,041s seconde, 78 498 nombres premiers trouvés.
Pour N = 1 000 000, avec dictionary, durée : 3,775s seconde, 78 498 nombres premiers trouvés.
Ici l'utilisation de Mod et d'une clé String ralentissent énormément le code.
Collection 3ème essai : de pire en pire !
Pour se passer de Mod, il va nous falloir penser différemment.
Ne plus comparer systématiquement tous les multiples, mais les supprimer.
Pour les supprimer, il faut que la liste soit préalablement établie.
Ici, nous allons donc :
- établir la collection des nombres impairs,
- réaliser une double boucle de suppression des multiples
Sub NBP_Collection_Remove() Dim NBP As New Collection Dim racine As Long, Max As Long, i As Long, j As Long Dim T As Single Max = 1000000 T = Timer NBP.Add 2, "2" 'boucle initiale For i = 3 To Max Step 2 NBP.Add i, CStr(i) Next 'double boucle racine = Sqr(Max) For i = 3 To racine Step 2 For j = i * 2 To Max Step i On Error Resume Next NBP.Remove CStr(j) Next Next i T = Timer - T Debug.Print "Pour N = " & Format(Max, "#,##0") & ", avec Collection.Remove, durée : " & Format(T, "0.000s") & " seconde, " & _ Format(NBP.Count, "#,##0") & " nombres premiers trouvés." End Sub
Les résultats :
Pour N = 10 000, avec Collection.Remove, durée : 0,141s seconde, 1 229 nombres premiers trouvés.
Pour N = 100 000, avec Collection.Remove, durée : 1,875s seconde, 9 592 nombres premiers trouvés.
Pour N = 1 000 000, avec Collection.Remove, durée : 27,008s seconde, 78 498 nombres premiers trouvés.
Nous avons toujours ce souci des String (dans la clé) qui ralentissent le code.
Fichiers à télécharger
Un classeur exemple est disponible ici : Fichier au format .xls
Pour tous les codes de la partie optimisation (et d'autres encore), : Fichier au format .xls