Acceleration Execution Macro

Le 13/07/2017 à 11:29

Bonjour,

Je vous envoie un message pour vous demander une aide.

Actuellement j'ai créer une barre de recherche sur plusieurs colonne, le but c'est que les noms soit surligné dès que j’écris une lettre dans la barre de recherche avec une liste en dessous.

Le problème c’est que malgré qu'elle fonctionne, elle est extrêmement lente ( si je met un a dans la barre de recherche j'en ai pour 30 seconde d’exécution)

J'espère avoir été claire, voici la macro:

Private Sub TextBox1_Change() 'www.blog-excel.com/creer-un-champ-de-recherche-vba

Application.ScreenUpdating = False

Range("B4:B40").Interior.ColorIndex = 2 'Exemple 1 (feuille)
Range("D10:D40").Interior.ColorIndex = 2 'Exemple 1 (feuille)
Range("E10:E40").Interior.ColorIndex = 2 'Exemple 1 (feuille)
Range("F10:F40").Interior.ColorIndex = 2 'Exemple 1 (feuille)
Range("G4:G40").Interior.ColorIndex = 2 'Exemple 1 (feuille)
Range("H4:H40").Interior.ColorIndex = 2 'Exemple 1 (feuille)

ListBox1.Clear 'Exemple 2 (ListBox)

If TextBox1 <> "" Then
For ligne = 4 To 40
If Cells(ligne, 2) Like "*" & TextBox1 & "*" Then
Cells(ligne, 2).Interior.ColorIndex = 39 'Exemple 1 (feuille)
ListBox1.AddItem Cells(ligne, 2) 'Exemple 2 (ListBox)
End If
Next
End If

If TextBox1 <> "" Then
For ligne = 10 To 40
If Cells(ligne, 4) Like "*" & TextBox1 & "*" Then
Cells(ligne, 4).Interior.ColorIndex = 39 'Exemple 1 (feuille)
ListBox1.AddItem Cells(ligne, 4) 'Exemple 2 (ListBox)
End If
Next
End If

If TextBox1 <> "" Then
For ligne = 10 To 40
If Cells(ligne, 5) Like "*" & TextBox1 & "*" Then
Cells(ligne, 5).Interior.ColorIndex = 39 'Exemple 1 (feuille)
ListBox1.AddItem Cells(ligne, 5) 'Exemple 2 (ListBox)
End If
Next
End If

If TextBox1 <> "" Then
For ligne = 10 To 40
If Cells(ligne, 6) Like "*" & TextBox1 & "*" Then
Cells(ligne, 6).Interior.ColorIndex = 39 'Exemple 1 (feuille)
ListBox1.AddItem Cells(ligne, 6) 'Exemple 2 (ListBox)
End If
Next
End If

If TextBox1 <> "" Then
For ligne = 4 To 40
If Cells(ligne, 7) Like "*" & TextBox1 & "*" Then
Cells(ligne, 7).Interior.ColorIndex = 39 'Exemple 1 (feuille)
ListBox1.AddItem Cells(ligne, 7) 'Exemple 2 (ListBox)
End If
Next
End If

If TextBox1 <> "" Then
For ligne = 4 To 40
If Cells(ligne, 8) Like "*" & TextBox1 & "*" Then
Cells(ligne, 8).Interior.ColorIndex = 39 'Exemple 1 (feuille)
ListBox1.AddItem Cells(ligne, 8) 'Exemple 2 (ListBox)
End If
Next
End If

End Sub

La barre de recherche n'est pas une macro de moi mais de Sebastien

Merci beaucoup pour votre aide.

Le 13/07/2017 à 20:24

Bonsoir,

Testes avec ce code :

Private Sub TextBox1_Change()

    Dim Plage As Range
    Dim Cel As Range
    Dim Adr As String

    ListBox1.Clear

    Set Plage = Application.Union(Range("B4:B40"), Range("D10:H40"), Range("G4:H9"))

    Plage.Interior.ColorIndex = 2

    If TextBox1 <> "" Then

        Set Cel = Plage.Find(TextBox1.Text, , xlValues, xlPart)

        If Not Cel Is Nothing Then

            Adr = Cel.Address

            Do

                Cel.Interior.ColorIndex = 39
                Set Cel = Plage.FindNext(Cel)
                ListBox1.AddItem Cel.Value

            Loop While Cel.Address <> Adr

        End If

    End If

End Sub
Le 13/07/2017 à 23:25

Bonsoir,

Autre proposition à essayer :

Private Sub TextBox1_Change()
    Dim Plg As Range, c As Range, TRech(), rch$, r%, clr&
    If TextBox1.Value = "" Then Exit Sub
    rch = "*" & TextBox1.Value & "*"
    clr = RGB(204, 153, 255)
    With ActiveSheet
        Set Plg = Union(.Range("B4:B40"), .Range("D10:F40"), .Range("G4:H40"))
        Application.ScreenUpdating = False
        Plg.Interior.ColorIndex = xlColorIndexNone
        For Each c In Plg
            If c Like rch Then
                c.Interior.Color = clr
                ReDim Preserve TRech(r)
                TRech(r) = c: r = r + 1
            End If
        Next c
    End With
    ListBox1.List = TRech
End Sub

Cordialement.

Le 14/07/2017 à 00:03

Bonjour à tous,

je n'ai pas testé vos 2 codes mais si vous stockiez vos cel dans un range avec union pour mettre la couleur en une fois à la fin ça pourrait faire un gain non ?

eric

Le 14/07/2017 à 00:12

Salut Eric,

J'avais en effet pensé à faire un tableau pour reporter les colorations à la fin, mais... mais j'ai trouvé qu'on avait une bonne amélioration de la rapidité sans en venir là... A voir !

Bonne fin de soirée.

NB- Mais l'idée d'un Range est à retenir.

Le 14/07/2017 à 00:47

J'ai testé par curiosité :

sur 100 boucles avec 3/4 des cellules colorées, on passe de 0.9 à 0.45s.

Bon, c'est vrai que c'est un cas extrêmement favorable, en réalité il y en a peut-être que 2% à colorer

Le 14/07/2017 à 01:02

En fait tu as raison ! parce que si on joue sur TextBox.Change, ça se déclenche à la première lettre, et le cas sera au départ défavorable (en temps) !

Le 14/07/2017 à 01:09

C'est vrai aussi, mais j'ai testé avec 100 boucles donc en réalité on parle de 0.005 s au lieu de 0.010s. Même pas le temps de penser à la touche suivante

Le 14/07/2017 à 01:14

Attendons le retour de l'usage ! Si nécessaire on a donc moyen d'améliorer...

Le 17/07/2017 à 12:58

Bonjour à tous et mes excuses pour cette réponse tardive.

Un grand Merci pour vos Réponses construites ! Cela m'a beaucoup aidé, j'ai essayer vos 2 codes, ils sont justes mais mon temps d’exécution avoisine toujours les 20 secondes...

Je pense pas que le problème vient de là mais d'une surcharge de données d'Excel, qu'en pensez-vous ?

J'aimerai volontiers vous expliquer l'intégralité de mon travail mais ce sont des données professionnelles et privées :/

Est-il possible ou alors via message privé de vous expliquer ?

Le 17/07/2017 à 13:09

Bonjour,

tout le monde peut anonymiser un fichier.

Il suffit de vider les colonnes inutiles pour le pb et de faire un Remplacer par sur qq lettres dont les voyelles.

Tiens, ça me donne l'idée d'un petit utilitaire : un anonymisateur (ou anonymiseur ??)

eric

Rechercher des sujets similaires à "acceleration execution macro"