VBA code de recherche probleme ligne surligner

bonjours a tous,

Je vous explique mon problème...

Grace a certain du forum(qui ont fait beaucoup) j'ai fait un classeur excel avec plusieurs feuilles qui contienne des tableau avec des informations et le dernière feuille est dédier a la recherche avec un textbox et une listbox, si je clique sur le résultat afficher dans ma listbox ça m’amène directement sur la ligne concerné dans la page concerné et ça la surligne en jaune ( Interior.ColorIndex = 6)

Le problème est que quand j'efface mon texte dans la textbox la ligne reste jaune et ne reviens pas a la couleur initiale (Interior.ColorIndex = 37)

Si jamais vous avez une solutions je suis preneur !

Merci par avance !

Je vous joint le code vba et le dossier anonymiser

Option Compare Text

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim L_index As Long
    L_index = ListBox1.ListIndex
    Cells(Tablo(L_index), 1).Activate

End Sub

Private Sub TextBox1_Change()
    Application.ScreenUpdating = False
    Dim sh As Integer, c As Range, firstAddress As String
    ListBox1.Clear
    For sh = 1 To Sheets.Count
      If sh.Name <> "Annuaire" Then
       With Worksheets(sh).Cells
        Set c = .Find(TextBox1.Value, LookIn:=xlValues)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
              ListBox1.AddItem c.Value
              ListBox1.List(ListBox1.ListCount - 1, 1) = sh.Name
              Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With

      End If
    Next
Exit Sub
    Erase Tablo()
    Range("A2:j" & Range("A" & Rows.Count).End(xlUp).Row).Interior.ColorIndex = 37
    ListBox1.Clear
    Cpt = 0
    If TextBox1 <> "" Then
        For ligne = 2 To Range("A" & Rows.Count).End(xlUp).Row
            If Cells(ligne, 1) Like "*" & TextBox1 & "*" Then
                Range(Cells(ligne, 1), Cells(ligne, 10)).Interior.ColorIndex = 6
                ListBox1.AddItem Cells(ligne, 1)
                ReDim Preserve Tablo(Cpt + 1)
                Tablo(Cpt) = ligne
                Cpt = Cpt + 1

            End If
        Next
    End If

End Sub

Bonjour Thrankill, bonjour le forum,

le code modifié :

Private Sub TextBox1_Change()
Dim sh As Integer, c As Range, firstAddress As String

ListBox1.Clear

'****************
'couleur initiale
'****************
If Me.TextBox1.Value = "" Then
    For sh = 1 To Sheets.Count
        If Sheets(sh).Name <> "Annuaire" Then
            Worksheets(sh).Cells.Interior.ColorIndex = 37
        End If
    Next sh
End If
'****************

If Len(Me.TextBox1.Value) = 0 Then Exit Sub
Application.ScreenUpdating = False
For sh = 1 To Sheets.Count
    If Sheets(sh).Name <> "Annuaire" Then
        With Worksheets(sh).Cells
            Set c = .Find(TextBox1.Value, LookIn:=xlValues)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    ListBox1.AddItem c.Value
                    ListBox1.List(ListBox1.ListCount - 1, 1) = Sheets(sh).Name
                    ListBox1.List(ListBox1.ListCount - 1, 2) = c.Row
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
        End With
    End If
Next
Application.ScreenUpdating = True
End Sub

Merci ThauTheme c'est parfait

Encore merci !

Bonjours, je me permet de ré ouvrir le sujet,

ThauTheme ta modif du code mâche super bien !

le seul problème est que j'ai du ajouter énormément de ligne sur toute mes feuilles (plus de 3000 ), ce qui fait que la recherche prend du temps quand je tape les lettres dans la textbox, est ce que quelqu'un ou toi ThauTheme aurait une solution pour ça ?

merci d avance !

Bonjour Thrankill, bonjour le forum,

Envoie un fichier exemple qu'on puisse travailler et tester...

Option Compare Text

Private Sub ListBox1_Click()
  Dim lig As Long
  lig = Val(ListBox1.Column(2))
  With Sheets(ListBox1.Column(1))
  .Select
  .Range("A" & lig).Select
  .Range(.Range("A" & lig), .Range("J" & lig)).Interior.ColorIndex = 6
  End With
End Sub

Private Sub TextBox1_Change()
Dim sh As Integer, c As Range, firstAddress As String

ListBox1.Clear

'****************
'couleur initiale
'****************
If Me.TextBox1.Value = "" Then
    For sh = 1 To Sheets.Count
        If Sheets(sh).Name <> "RECHERCHE" Then
            Worksheets(sh).Cells.Interior.ColorIndex = 37
        End If
    Next sh
End If
'****************

If Len(Me.TextBox1.Value) = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For sh = 1 To Sheets.Count
    If Sheets(sh).Name <> "RECHERCHE" Then
        With Worksheets(sh).Cells
            Set c = .Find(TextBox1.Value, LookIn:=xlValues)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    ListBox1.AddItem c.Value
                    ListBox1.List(ListBox1.ListCount - 1, 1) = Sheets(sh).Name
                    ListBox1.List(ListBox1.ListCount - 1, 2) = c.Row
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress

            End If
        End With
    End If
Next
 Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Bonjour ThauTheme, bonjour le forum !

Je joint ci dessous le dossier anonymiser, le code vba reste le même je le joint quand même

Les ordinateurs utilisé ne sont pas de dernière générations ça ne doit pas aider mais le temps de recherche est tout de même très long

J’espère qu'une solutions existe !

Bonjour Thrankill (je vient de comprendre à peine ton pseudo ), bonjour le forum,

Une autre méthode. Au lieu d'agir dès que l'on tape une lettre il faudra cliquer sur la flèche RESULTAT pour lancer le code. Utilisation de tableau virtuel TV plutôt que la méthode Find... Tu me diras si ça convient au niveau vitesse d'exécution.

Bonjour ThauTheme,

Oui un ancien pseudo que j'aime bien

Ta solution est parfaite !! Çà marche a merveille, l'utilisation est même encore mieux !!

Si je peux abuser encore de ton expertise ...

Comme au début le problème est que quand j'efface mon texte dans la textbox la ligne reste jaune et ne reviens pas a la couleur initiale (Interior.ColorIndex = 37)

J'ai juste déplacer le bout du code dans la textbox et ça fonctionne mais il y a une lenteur quand on efface qui reste minime mais si jamais tu as une idée encore une fois je suis preneur. (je joint le fichier avec le code que j'ai déplacer )

Sinon encore merci ton changement est top !!

Bonsoir Thrankill, bonsoir le forum,

Non je n'ai pas mieux. Tu sais, colorer toutes les cellules d'un onglet représente 1 048 576 x 16384 = 17 179 869 184 cellules et tu as 5 onglets !... Finalement ce n'est pas si lent que ça...

Re,

Cette réponse me laisse sans voix...

Re,

Je comprend pas pourquoi rien ne s'affiche ...

Je disais que effectivement vue comme ça le temps de réaction n'est pas si long que ça et en l'utilisant il ne se remarque presque plus

Encore merci pour tout ThauTheme !!