Problème fonction recherche vba

[Résolu]
Signaler
Messages postés
360
Date d'inscription
dimanche 3 décembre 2006
Statut
Membre
Dernière intervention
3 janvier 2012
-
Messages postés
3877
Date d'inscription
mardi 19 mars 2002
Statut
Membre
Dernière intervention
23 août 2018
-
Bonjour à tous,

J'ai une petite modification à faire dans se script mais j'ai de la difficulté à trouver ou est le problème.

Je ne veux pas que la recherche se face dans tous les feuil, mais juste dans la basse de données.

Voici le script:
<hr size="2" width="100%" />Public Function FindWords(ByVal sWord As String) As String()
        Dim rStartCell      As Range
        Dim FindWord()      As String
        Dim i               As Long:    i = 0
        Dim z               As Long
        Dim Max             As Long
        Dim oSheet          As Worksheet
        Dim ActualSheet     As String
        Dim SheetName       As String
        Dim NumRow          As String
        Dim Datas           As String
       
        '************************************
        Dim NoDupes         As New Collection
        '************************************

       
    ActualSheet = ActiveWorkbook.ActiveSheet.Name

       
    For Each oSheet In ActiveWorkbook.Worksheets

        oSheet.Select: Range("U65536").Select: SheetName = Space(8) & "FEUILLE : " & oSheet.Name

            On Error Resume Next
        Cells.Find(sWord).Activate

        If Not (Err.Number = 91) Then

                ReDim Preserve FindWord(i)

           
            NumRow = Space(8) & "LIGNE : " & Str$(ActiveCell.Row)

            Set rStartCell = ActiveCell

           
            For z = 1 To LastColumn(ActiveCell.Row)

                Datas = Datas & sSeparator & CStr(Cells(ActiveCell.Row, z).Text)

            Next z
           
            FindWord(i) = SheetName & sSeparator & NumRow & sSeparator & Datas & sSeparator
            i = i + 1

           
            Do

                Cells.Find(sWord, Cells(ActiveCell.Row + 1, 1)).Activate

                If ActiveCell.Address = Range(rStartCell.Address).Address Then Exit Do

                NumRow = Space(8) & "LIGNE : " & Str$(ActiveCell.Row)
                    ReDim Preserve FindWord(i)
               
                Max = LastColumn(ActiveCell.Row)
                For z = 1 To Max
               
                '*******************************************
                    NoDupes.Add Cells(ActiveCell.Row, z).Value, CStr(Cells(ActiveCell.Row, z).Text)
                    If Err.Number = 457 Then Err.Clear: Exit For
                    '*******************************************

                    Datas = Datas & sSeparator & CStr(Cells(ActiveCell.Row, z).Text)
                Next z
                FindWord(i) = SheetName & sSeparator & NumRow & sSeparator & Datas & sSeparator
                i = i + 1
            Loop
        End If
    Next oSheet
   
    Sheets(ActualSheet).Select

    FindWords = FindWord: Erase FindWord

'*************************
    For i = NoDupes.Count To 1 Step -1
        NoDupes.Remove (i)
    Next i
Set NoDupes = Nothing

    '*************************

   
End Function
<hr size="2" width="100%" />Merci de votre aide

27 réponses

Messages postés
3877
Date d'inscription
mardi 19 mars 2002
Statut
Membre
Dernière intervention
23 août 2018
19
Salut à toi, habitant de la Rive Sud ... ainsi qu'à toi Mortalino.

Voici un autre exemple utilisant Find et FindNext
Chaque enregistrement du tableau résultat est une ligne trouvée dont les cellules sont séparées par le séparateur mis en paramètre. Si tu veux que chaque cellule soit un item du tableau, il faudra le redimensionner dans la recherche horizontale (dans la boucle For I ...Next)

Option Explicit

Sub Départ()
    Dim Tableau As Variant
   
    Tableau = RechercheMot("RONA", ";")  ' ou RechercheMot("Rona", vbCrLf)

    If Tableau(0) = "" Then
        MsgBox "Aucune valeur trouvée"
    Else
        MsgBox Tableau(0) ' pour visualiser le résultat d'une ligne
    End If
End Sub

Function RechercheMot(Mot As String, Séparateur As String) As String()
    Dim I As Long, nbItems As Long, nbColonnes As Integer
    Dim Recherche As Range, Adresse As String
    Dim strTemp As String, tablo() As String
   
    ReDim tablo(0)
    nbColonnes = Cells.Find("*", Range("A1"), , , xlByColumns, xlPrevious).Column
   
    'première recherche à la verticale
    '   « Columns("G") » peut être remplacé par « Cells »
    Set Recherche = Columns("G").Find(Mot, LookAt:=xlPart, MatchCase:=False)
    If Not Recherche Is Nothing Then
        Adresse = Recherche.Address 'stocke l'adresse de départ
        Do
        'Deuxième recherche à l'horizontale
            'redimensionner le tableau
            ReDim Preserve tablo(nbItems)
           
            'Lire la ligne en insérant le séparateur
            For I = 1 To nbColonnes
                strTemp = strTemp & Cells(Recherche.Row, I) & Séparateur
            Next
           
            'enlever le dernier séparateur en trop
            strTemp = Left(strTemp, Len(strTemp) - Len(Séparateur))
           
            'Insérer la ligne au tableau
            tablo(nbItems) = strTemp
            nbItems = nbItems + 1  ' pour le redimensionnement au prochain passage
           
            Set Recherche = Columns("G").FindNext(Recherche)
        Loop Until Recherche.Address = Adresse Or Recherche Is Nothing
    End If
   
    RechercheMot = tablo
End Function
.

MPi
Messages postés
360
Date d'inscription
dimanche 3 décembre 2006
Statut
Membre
Dernière intervention
3 janvier 2012
3
Donc si je comprend bien, avec se script, je peux toujours l'utiliser pour avoir les résultat de recherche dans mon ListBox1 après avec mis le mots à rechercher dans mon textbox1 et cliqué sur un bouton rechercher?
Messages postés
3877
Date d'inscription
mardi 19 mars 2002
Statut
Membre
Dernière intervention
23 août 2018
19
Ben, sans tester, je remplacerais la boucle For I...Next
Et laisse tomber le tableau qui ne sert pas vraiment si c'est une Listbox à remplir...

Quelque chose comme

            'Lire la ligne en insérant le séparateur
            For I = 1 To nbColonnes
                Listbox1.AddItem Cells(Recherche.Row, I)
            Next
          'et un autre AddItem pour une ligne vide
          Listbox1.AddItem

          'Et éventuellement un AddItem avant le For I... pour insérer le titre comme tu semblais vouloir le faire

Donne-moi quelques minutes ...
MPi
Messages postés
3877
Date d'inscription
mardi 19 mars 2002
Statut
Membre
Dernière intervention
23 août 2018
19
Tu peux enlever la déclaration nbItems qui ne sert plus ...

MPi
Messages postés
360
Date d'inscription
dimanche 3 décembre 2006
Statut
Membre
Dernière intervention
3 janvier 2012
3
Super cette facon de faire aussi. J'aime bien.

Met je me rend compte qu'il me donne seulement le numéro de la ligne et la valeur de la celule A de la ligne.

Il faudrait qu'il me donne la valeur de la colone A à  Z.

donc je devrais modifier cette partie je crois:

  'Lire la ligne
            UserForm1.ListBox1.AddItem Space(8) & "LIGNE : " & Recherche.Row
            For I = 1 To nbColonnes
                UserForm1.ListBox1.AddItem Cells(Recherche.Row, I)   
Messages postés
360
Date d'inscription
dimanche 3 décembre 2006
Statut
Membre
Dernière intervention
3 janvier 2012
3
oups, j'avais marqué :
nbColonnes = Cells.Find("*", Range(" A4 "), , , xlByColumns, xlPrevious).Column

j'ai chamgé pour :
nbColonnes = Cells.Find("*", Range("A1"), , , xlByColumns, xlPrevious).Column

La, ça fonctionne!

Je te redonne des nouvelles.

merci
Messages postés
3877
Date d'inscription
mardi 19 mars 2002
Statut
Membre
Dernière intervention
23 août 2018
19
Ce ne serait pas supposé ...

'Cette ligne inscrit le numéro de ligne en guise d'entête de chaque section
            UserForm1.ListBox1.AddItem Space(8) & "LIGNE : " & Recherche.Row

'Ici, ça boucle de la colonne A jusqu'au nombre de colonnes utilisées sur la feuille active
'et ça ajoute la valeur de chaque cellule à la Listbox
            For I = 1 To nbColonnes
                UserForm1.ListBox1.AddItem Cells(Recherche.Row, I)

MPi