VBA Excel - Nombres premiers

Dernière mise à jour le 26 janvier 2017 à 09:03 par pijaku .

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

A voir également

Nombre premier vba
Nombre premier pascal ✓ - Forum - Pascal
Algorithme nombre premier - Conseils pratiques - Langage C
Nombre premier en c ✓ - Forum - C
Nombre premier java ✓ - Forum - Programmation
Nombre premier recursive - Forum - Programmation

Ce document intitulé « VBA Excel - Nombres premiers » issu de Comment Ça Marche (www.commentcamarche.net) est mis à disposition sous les termes de la licence Creative Commons. Vous pouvez copier, modifier des copies de cette page, dans les conditions fixées par la licence, tant que cette note apparaît clairement.

VBA - Un contrôle listbox transparent

VBA - Vérifier si variable stockée dans une variable tableau