Optimisation de macro VBA

chkeuz · 27 Avril 2009

Bonjour à tous et toutes sur le forum, et désolé pour ce nouveau thread....
Permettez moi tout d'abord de vous exposer mon problème.
Avec l'aide précieuse de Pierre Jean, j'ai confectionné une macro effectuant une recherche mutlicritères dans une base de données comprenant jusqu'à 30.000 items tous différents.
Ma recherche passe par une interface de recherche, affichant des critères qui permettent d'affiner la recherche d'un item. Enfin, un double clic sur un item permet d'en afficher les caractéristiques, qui sont ces mêmes critères de recherche mentionnés en sus.
Je vous joins un extrait du fichier, pour mieux comprendre.
Mon problème vient du fait que la recherche est, certes précise, mais surtout extrêmement longue dès qu'on atteint 4000 lignes! (le module met 5mn à se lancer... quand il se lance....).
Je pense que le problème vient de boucles intempestives, et cherche à épurer mon code pour améliorer les performances.
Je précise que je ne suis pas un assisté, et que je préfère trouver les solutions par moi-même... cela dit, dans ce cas précis, je nage...
J'implore votre oeil avisé, en espérant qu'un PJ passera par là...
Lien vers le fichier: .
Merci d'avance!!

Bernard_XLD · 27 Avril 2009

Re : Optimisation de macro VBA

Salut

j'ai reprogrammé ta macro de recherche avec des tableaux VB, 25'' de recherche sur mon ordi sur 4500 valeurs

Cordialement, @+

Code:

Private Sub InitCombo(LCombo As Object, nomCol As String)
    Dim lig As Long
    Dim nbElement As Integer
    Dim trouveElm As Boolean
    Dim Tab_Val As Variant, Tab_Val2() As Variant, Nb_Val As Long
    Tab_Val = Range(nomCol & "3:" & nomCol & Range(nomCol & "65536").End(xlUp).Row).Value
    LCombo.Clear
    Nb_Val = 0
    ReDim Tab_Val2(1 To 1) As Variant
    ' Boucle de la ligne 2 à la dernière ligne dans la colonne nomCol
    For lig = LBound(Tab_Val) To UBound(Tab_Val)
        trouveElm = False
 
        ' Vérifier que l'élément à ajouter dans la liste n'existe pas déjà
        If Nb_Val > 0 Then
            For nbElement = 1 To Nb_Val
                ' L'élément est déjà présent dans la liste, sortie de la boucle
                If Tab_Val2(nbElement) = Tab_Val(lig, 1) Then
                    trouveElm = True
                    Exit For
                End If
            Next nbElement
        End If
 
        ' Elément non trouvé dans la liste, l'ajouter
        If trouveElm = False Then
            Nb_Val = Nb_Val + 1
            ReDim Preserve Tab_Val2(1 To Nb_Val)
            Tab_Val2(Nb_Val) = Tab_Val(lig, 1)
        End If
    Next lig
    LCombo.List() = Tab_Val2
End Sub

Bernard_XLD · 27 Avril 2009

Re : Optimisation de macro VBA

re

on peut faire beaucoup plus rapide en reprenant l'ensemble du code si celà t'intéresse

re @+

chkeuz · 28 Avril 2009

Re : Optimisation de macro VBA

Merci beaucoup!
Je m'occupe de l'application de ton nouveau code dès maintenant. Très bonne idée, les variables....Je serais, en effet, vraiment intéressé de redévelopper le code si tu en as le temps, pour des applications futures. N'hésite pas à me faire signe!!Je te tiens au courant de l'évolution très vite.
Pour info, le problème venait des boucles, non? Tu as remplacé la lecture des colonnes par des variables?Ne devrait on pas alors en définir quelques unes (des variables fixes, en somme) pour optimiser le calcul?Encore merci pour ta réponse super rapide!🙂

Bernard_XLD · 28 Avril 2009

Re : Optimisation de macro VBA

Salut

pas de quoi, cela m'a pris 5'
le problème venait de l'incrémentation d'objets combobox, c'est beaucoup plus rapide de travailler avec un tableau et de transférer ensuite le tableau entier dans la combo.
pour accélérer encore, il faut faire le même principe avec la proc rechercher mais c'est un poil plus compliqué car il faut gérer les filtres, l'étape suivante est de travailler uniquement avec des tableaux tout en gérant les raz sans redémarrer l'userform.
Dés que j'ai une petite heure, je regarde.

@+

chkeuz · 28 Avril 2009

Re : Optimisation de macro VBA

Super!! Effectivement, le temps de chargement a conséquemment diminué!!
(on passe de 4mn à 21s sur ma bécane, 45s max sur des ordis moins puissants....) J'ai hâte d'essayer la solution "tout-tableau" conjointement avec toi! Merci encore pour ton aide précieuse, et à bientôt donc pour la suite de cette aventure!🙂

pierrejean · 28 Avril 2009

Re : Optimisation de macro VBA

bonjour chkeuz

Salut Yeahou 🙂

A tester: modif des sub inicombo et rechercher (et celles qui les appelent)

Code:

Private Sub IniCombo(LCombo As Object, nomCol As String)
Dim coll As Collection
Set coll = New Collection
derlin = Range(nomCol & 65536).End(xlUp).Row
tablo = Range(Range(nomCol & 3), Range(nomCol & derlin))
For n = LBound(tablo) To UBound(tablo)
  On Error Resume Next
    coll.Add tablo(n, 1), CStr(tablo(n, 1))
    If Err.Number = 0 Then LCombo.AddItem tablo(n, 1)
  On Error GoTo 0
Next n
End Sub
Private Sub Rechercherb()
    Dim Critere(1 To 9) As String
    Critere(1) = "*"
    If RechercheC1.Value <> "" Then Critere(1) = RechercheC1.Value
    Critere(2) = "*"
    If RechercheC2.Value <> "" Then Critere(2) = RechercheC2.Value
    Critere(3) = "*"
    If RechercheC3.Value <> "" Then Critere(3) = RechercheC3.Value
    Critere(4) = "*"
    If RechercheC4.Value <> "" Then Critere(4) = RechercheC4.Value
    Critere(5) = "*"
    If RechercheC5.Value <> "" Then Critere(5) = RechercheC5.Value
    Critere(6) = "*"
    If RechercheC6.Value <> "" Then Critere(6) = RechercheC6.Value
    Critere(7) = "*"
    If RechercheC7.Value <> "" Then Critere(7) = RechercheC7.Value
    Critere(8) = "*"
    If RechercheC8.Value <> "" Then Critere(8) = RechercheC8.Value
    Critere(9) = "*"
    If RechercheC9.Value <> "" Then Critere(9) = RechercheC9.Value
    ListBoxLocataire.Clear
tablo = Range("A3:I" & Range("A65536").End(xlUp).Row)
For n = LBound(tablo, 1) To UBound(tablo, 1)
        If tablo(n, 1) Like Critere(1) And tablo(n, 2) Like Critere(2) And tablo(n, 3) Like Critere(3) And tablo(n, 4) Like Critere(4) And tablo(n, 5) Like Critere(5) And tablo(n, 6) Like Critere(6) And tablo(n, 7) Like Critere(7) And tablo(n, 8) Like Critere(8) And tablo(n, 9) Like Critere(9) Then
            With ListBoxLocataire
                .AddItem tablo(n, 1)
                .List(.ListCount - 1, 1) = tablo(n, 2)
                .List(.ListCount - 1, 2) = tablo(n, 3)
                .List(.ListCount - 1, 3) = tablo(n, 4)
                .List(.ListCount - 1, 4) = tablo(n, 5)
                .List(.ListCount - 1, 5) = tablo(n, 6)
                .List(.ListCount - 1, 6) = tablo(n, 7)
                .List(.ListCount - 1, 7) = tablo(n, 8)
                .List(.ListCount - 1, 8) = tablo(n, 9)
            End With
        End If
Next n
End Sub

Note: Je n'ai pas traité RechercheCx

Chez moi la reponse est de 25 secondes pour 6000 lignes

Bernard_XLD · 28 Avril 2009

Re : Optimisation de macro VBA

Re Bonjour Chkeuz, salut PierreJean

j'en ai profité pour alléger un peu le code
essayé avec 5500 valeurs, quasi instantanné

Cordialement, @+

les macros de recherche

Code:

Private Sub CommandButton1_Click()
    Dim Compteur As Integer
    For Compteur = 1 To 9
        Me.Controls("RechercheC" & Compteur).Value = ""
    Next Compteur
    Call Rechercher
End Sub
Private Sub ListBoxLocataire_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    ligSelect = ListBoxLocataire.ListIndex
 
    usfAffichage.Show
End Sub
Private Sub RechercheC2_Change()
    ' Rechercher les données en fonction des critères sélectionnés
    Call Rechercher
End Sub
Private Sub RechercheC3_Change()
    ' Rechercher les données en fonction des critères sélectionnés
    Call Rechercher
End Sub
Private Sub RechercheC4_Change()
    ' Rechercher les données en fonction des critères sélectionnés
    Call Rechercher
End Sub
Private Sub RechercheC5_Change()
    ' Rechercher les données en fonction des critères sélectionnés
    Call Rechercher
End Sub
Private Sub RechercheC6_Change()
    ' Rechercher les données en fonction des critères sélectionnés
    Call Rechercher
End Sub
Private Sub RechercheC7_Change()
    ' Rechercher les données en fonction des critères sélectionnés
    Call Rechercher
End Sub
Private Sub RechercheC8_Change()
    ' Rechercher les données en fonction des critères sélectionnés
    Call Rechercher
End Sub
Private Sub RechercheC9_Change()
    ' Rechercher les données en fonction des critères sélectionnés
    Call Rechercher
End Sub
Private Sub UserForm_Initialize()
    Range("A2").Select
    ' Initialiser les listes des critères
    Call InitCombo(RechercheC1, "A")
    Call InitCombo(RechercheC2, "B")
    Call InitCombo(RechercheC3, "C")
    Call InitCombo(RechercheC4, "D")
    Call InitCombo(RechercheC5, "E")
    Call InitCombo(RechercheC6, "F")
    Call InitCombo(RechercheC7, "G")
    Call InitCombo(RechercheC8, "H")
    Call InitCombo(RechercheC9, "I")
    ' Rechercher les données en fonction des critères sélectionnés
    Call Rechercher
End Sub
Private Sub RechercheC1_Change()
    ' Rechercher les données en fonction des critères sélectionnés
    Call Rechercher
End Sub
Private Sub Rechercher()
    ' Rechercher les données en fonction des critères 1 et 2
    Dim lgLigDeb As Long
    Dim Tab_Val As Variant, Tab_Val2() As Variant, Nb_Val, Compteur As Integer
    Dim Critere(1 To 9) As String
 
    For Compteur = 1 To 9
        If Me.Controls("RechercheC" & Compteur).Value <> "" Then Critere(Compteur) = Me.Controls("RechercheC" & Compteur).Value Else Critere(Compteur) = "*"
    Next Compteur
    ListBoxLocataire.Clear
    Tab_Val = Range("A3:J" & Range("A65536").End(xlUp).Row).Value
    Nb_Val = 0
    ReDim Tab_Val2(1 To UBound(Tab_Val), 1 To 9) As Variant
 
    ' Boucle de la 2me à la dernière ligne de la feuille Feuil1
    For lgLigDeb = LBound(Tab_Val) To UBound(Tab_Val)
        If Tab_Val(lgLigDeb, 1) Like Critere(1) And Tab_Val(lgLigDeb, 2) Like Critere(2) And Tab_Val(lgLigDeb, 3) Like _
        Critere(3) And Tab_Val(lgLigDeb, 4) Like Critere(4) And Tab_Val(lgLigDeb, 5) Like Critere(5) And Tab_Val(lgLigDeb, 6) _
        Like Critere(6) And Tab_Val(lgLigDeb, 7) Like Critere(7) And Tab_Val(lgLigDeb, 8) Like Critere(8) And Tab_Val(lgLigDeb, 9) Like Critere(9) Then
            Nb_Val = Nb_Val + 1
            For Compteur = 1 To 9
                Tab_Val2(Nb_Val, Compteur) = Tab_Val(lgLigDeb, Compteur)
            Next Compteur
        End If
    Next lgLigDeb
    ListBoxLocataire.List() = Tab_Val2
End Sub
Private Sub InitCombo(LCombo As Object, nomCol As String)
    Dim lig As Long, nbElement As Integer, trouveElm As Boolean, Tab_Val As Variant, Tab_Val2() As Variant, Nb_Val As Long
    Tab_Val = Range(nomCol & "3:" & nomCol & Range(nomCol & "65536").End(xlUp).Row).Value
    LCombo.Clear
    Nb_Val = 0
    ReDim Tab_Val2(1 To 1) As Variant
    ' Boucle de la ligne 2 à la dernière ligne dans la colonne nomCol
    For lig = LBound(Tab_Val) To UBound(Tab_Val)
        trouveElm = False
        ' Vérifier que l'élément à ajouter dans la liste n'existe pas déjà
        If Nb_Val > 0 Then
            For nbElement = 1 To Nb_Val
                ' L'élément est déjà présent dans la liste, sortie de la boucle
                If Tab_Val2(nbElement) = Tab_Val(lig, 1) Then
                    trouveElm = True
                    Exit For
                End If
            Next nbElement
        End If
        ' Elément non trouvé dans la liste, l'ajouter
        If trouveElm = False Then
            Nb_Val = Nb_Val + 1
            ReDim Preserve Tab_Val2(1 To Nb_Val)
            Tab_Val2(Nb_Val) = Tab_Val(lig, 1)
        End If
    Next lig
    LCombo.List() = Tab_Val2
End Sub

les macros de l'USFaffichage

Code:

Private Sub cmdOK_Click()
    Unload usfAffichage
End Sub
Private Sub UserForm_Initialize()
    Dim Compteur As Integer
    For Compteur = 0 To 8
        Me.Controls("txtCritere" & Compteur + 1).Value = Recherche.ListBoxLocataire.Column(Compteur, ligSelect)
    Next Compteur
End Sub

Bernard_XLD · 29 Avril 2009

Re : Optimisation de macro VBA

Salut Chkeuz, Pierrejean

j'ai reprogrammé InitCombo en utilisant la méthode de PierreJean conjointement avec une ini par tableau entier, on gagne encore en rapidité. Cette astuce pour éviter les doublons dans une liste simple a été évoquée pour la première fois en 2004 par Thierry si je me rappelle bien, elle est bien adaptée à ce cas précis.

Cordialement, A+

Code:

Private Sub InitCombo(LCombo As Object, nomCol As String)
    Dim Lig As Long, Tab_Val As Variant, Tab_Val2() As Variant, Nb_Val As Long
    Dim Coll As Collection
    Set Coll = New Collection
    Tab_Val = Range(nomCol & "3:" & nomCol & Range(nomCol & "65536").End(xlUp).Row).Value
    Nb_Val = 0
    ReDim Tab_Val2(1 To 1) As Variant
    LCombo.Clear
    For Lig = LBound(Tab_Val) To UBound(Tab_Val)
        On Error Resume Next
        Coll.Add Tab_Val(Lig, 1), CStr(Tab_Val(Lig, 1))
        If Err.Number = 0 Then
            Nb_Val = Nb_Val + 1
            ReDim Preserve Tab_Val2(1 To Nb_Val)
            Tab_Val2(Nb_Val) = Tab_Val(Lig, 1)
        End If
        On Error GoTo 0
    Next Lig
    LCombo.List() = Tab_Val2
End Sub

chkeuz · 5 Mai 2009

Re : Optimisation de macro VBA

Bonjour le fil, le forum, et à tous les maîtres de l'optimisation!!
Tout d'abord, merci pour vos nombreuses réponses, et pour le temps consacré par chacun de vous à ce challenge. Tiens, je vous embrasserais bien, mais mon écran est un peu sale..Excusez moi pour le retard de mes remerciements, je reviens tout juste au boulot après trois jours de congé paternité...En tout cas, on peut dire que le code est sacrément optimisé! On est passés de 4mn à 3s!!Bravo tout le monde, merci PierreJean notre maître à tous, et Yeahou le codeur fou! Et vive excel-downloads, the place to be!

Optimisation de macro VBA

chkeuz

XLDnaute Nouveau

Bernard_XLD

XLDnaute Barbatruc

Bernard_XLD

XLDnaute Barbatruc

chkeuz

XLDnaute Nouveau

Bernard_XLD

XLDnaute Barbatruc

chkeuz

XLDnaute Nouveau

pierrejean

XLDnaute Barbatruc

Pièces jointes

Bernard_XLD

XLDnaute Barbatruc

Bernard_XLD

XLDnaute Barbatruc

chkeuz

XLDnaute Nouveau

Optimisation de macro VBA

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Nouveau

Privacy & Transparency

Privacy & Transparency