Boite Recherche de mot dans fichier excel 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
360
Date d'inscription
dimanche 3 décembre 2006
Statut
Membre
Dernière intervention
3 janvier 2012
-
Bonjour,

J'ai crée une boite de recherche VBA et j'ai de la difficulté avec la fonction FindNext.

Voici mon script:

Private Sub CommandButton1_Click()
Dim recherche As String
On Error GoTo erreur

recherche = Application.InputBox(Prompt:="Tapez votre recherche, puis cliquez sur Ok. Le curseur se déplacera alors sur votre requète", Title:="Recherche", Default:="Tapez votre recherche", Type:=2)

Cells.Find(What:=recherche, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _
.Activate
'(Cells.FindNext(After:=ActiveCell).Activate)
GoTo Fin
erreur:
MsgBox "Vous devez saisir une recherche"
Fin:
End Sub.

Que puis-je faire pour que la boite reste ouvert et que je puise faire FindNext s'il y a plus qu'une valeur au mot recherché?

Merci

28 réponses

Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
Non, non, non !
Entre guillemets, c'est du texte qu'il va rechercher :
Quand tu mets
sResult = FindWords("TextBox1.Text")

 lui, il chercher TextBox1.Text dans les cellules Excel. Enlève les guillemets et précise le nom du UserForm :
sResult = FindWords(UserForm1.TextBox1.Text)

Ca c'est la première chose à touché, la seconde c'est :
Debug.Print ParseResult(j)

Remplace le par MsgBox ParseResult(j)

Tu verras mieux
Si tu as une ListBox dans ton UserForm, tu peux aussi faire ça :
UserForm1.ListBox1.AddItem ParseResult(j)

Le reste il ne faut pas toucher, ca s'adpate.

@++

<hr width="100%" size="2" />
  --Mortalino--
Le mystérieux chevalier, ~Provençal, le Gaulois~
  
Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
Oui, tu peux éviter ceci en utilisant une collection. Pourquoi une collection ? car elle provoque une erreur si on ajoute un doublon.


Je t'ai encadré les 3 choses à rajouter :

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("IV65536").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).Value)
            Next z
            
            FindWord(i) = SheetName & sSeparator & NumRow & Datas
            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).Value)
                    If Err.Number = 457 Then Err.Clear: Exit For
                    '*******************************************
                    Datas = Datas & sSeparator & CStr(Cells(ActiveCell.Row, z).Value)
                Next z
                FindWord(i) = SheetName & sSeparator & NumRow & Datas
                i = i + 1
            Loop
        End If
    Next oSheet
    
    Sheets(ActualSheet).Select
    FindWords = FindWord: Erase FindWord
    '*************************
    For i = 1 To NoDupes.Count
        NoDupes.Remove (i)
    Next i
    Set NoDupes = Nothing
    '*************************
End Function

~ <small> Mortalino ~ Colorisation automatique </small>

@++





<hr width ="100%" size="2" />

  --Mortalino--
Le mystérieux chevalier, ~Provençal, le Gaulois~
  
Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
Remplace dans :

                    '*******************************************
                    NoDupes.Add Cells(ActiveCell.Row, z).Value, CStr(Cells(ActiveCell.Row, z).Value)
                    If Err.Number =  457 Then Err.Clear: Exit For
                    '*******************************************

z par le numéro de la colonne à vérifier (là où se trouvent tes prénoms, si j'ai bien suivi)

@++

<hr width ="100%" size="2" />
  --Mortalino--
Le mystérieux chevalier, ~Provençal, le Gaulois~
  
Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
Décidemment,.. (désolé)

fait l'inverse ici :

    <strike>For i = 1 To </strike><strike>NoDupes.Count</strike>
    For i = NoDupes.Count To 1 Step -1
        NoDupes.Remove (i)
    Next i

@++

<hr width="100%" size="2" />
  --Mortalino--
Le mystérieux chevalier, ~Provençal, le Gaulois~
  
Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
Oui, c'est faisable,

remplace les deux
Datas = Datas & sSeparator & CStr
(Cells(ActiveCell.Row, z).Value)
par
Datas = Datas & sSeparator & CStr(Cells(ActiveCell.Row, z).TEXT)

Testé, c'est ok ;)

@++

<hr width="100%" size="2" />
  --Mortalino--
Le mystérieux chevalier, ~Provençal, le Gaulois~
  
Messages postés
360
Date d'inscription
dimanche 3 décembre 2006
Statut
Membre
Dernière intervention
3 janvier 2012
3
Je recommence.

Mon script:
Private Sub CommandButton1_Click()
Dim recherche As String
On Error GoTo erreur

recherche = Application.InputBox(Prompt:="Tapez votre recherche, puis cliquez sur Ok. Le curseur se déplacera alors sur votre requète", Title:="Recherche", Default:="Tapez votre recherche", Type:=2)

Cells.Find(What:=recherche, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _
.Activate
'(Cells.FindNext(After:=ActiveCell).Activate)
GoTo Fin
erreur:
MsgBox "Vous devez saisir une recherche"
Fin:
End Sub

Que puis-je faire pour que la boite reste ouvert et que je puise faire
FindNext s'il y a plus qu'une valeur au mot recherché? Merci

PS: Pas bon de poster avec Opéra !!!!
Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
Salut,

je ne sais pas si ça t'intéresse, mais j'ai une fonction assez proche, ICI. (t'auras du code)

Sinon, pour ton problème de FindNext :

Ceci dans un Bouton "Suivant" :

            Cells.FindNext(After:=ActiveCell).Activate

@++

<hr size="2" width="100%" />
  --Mortalino--
Le mystérieux chevalier, ~Provençal, le Gaulois~
  
Messages postés
360
Date d'inscription
dimanche 3 décembre 2006
Statut
Membre
Dernière intervention
3 janvier 2012
3
Salut mortalino,

Donc si j'ai bien comprit le script de la page en référence, si j'ai plusieurs onglet, se moteur de recherche va chercher dans tous les onglets?

Ai-je bien comprit ?
Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
Re,

et non, en fait mon snippet ne prend en compte que la page que lui donne en paramètre.
Si tu veux je peux le modifier suivant tes besoins. Dans ce cas, dis moi ce qu'il te faut exactement.

@++

<hr width="100%" size="2" />
  --Mortalino--
Le mystérieux chevalier, ~Provençal, le Gaulois~
  
Messages postés
360
Date d'inscription
dimanche 3 décembre 2006
Statut
Membre
Dernière intervention
3 janvier 2012
3
Merci mortalino,

En réalité, j'ai plusieurs onglets qui correspond à des noms de
personnes car ce document Excel correspond à une base de données des commandes
fait par différentes personnes.


La boîte de recherche droit voir tous les onglets du fichier Excel si possible.

Donc faire des recherche par mots et ainsi me donner tous les infos de la ligne qui contient le mot choisi.

Est-ce trop compliqué à réaliser tu crois?
Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
Non, c'est facile à faire, je regarde ça de suite.

@++

<hr width="100%" size="2" />
  --Mortalino--
Le mystérieux chevalier, ~Provençal, le Gaulois~
  
Messages postés
360
Date d'inscription
dimanche 3 décembre 2006
Statut
Membre
Dernière intervention
3 janvier 2012
3
merci 
Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
Beh je suis pas loin, je voulais te récupérer les résultats sous formes de Tableau (variable), avec la dimension 1 -> NomSheet, dimension 2 ->, numéro ligne, dimension 3 -> Les données de chaques colonnes.

Cependant, j'éprouve une difficulté bizarre avec la méthode FindNext, suivant où je le place ça fonctionne, ou non. Hélas, ça ne fonctionne pas là où ça devrait.
C'est dommage, à part ça, c'est vite fait. Si t'as une soluce, ou quelqu'un d'autre, ce serait cool. (en commentaires..)

Voici déjà mon début de code :

Function LastColumn(ByVal MyRow As Long) As Integer
    LastColumn =  Rows(MyRow).Find("").Column - 1
End Function

Public Function FindWords(ByVal sWord As String) As String()
        Dim rStartCell      As Range
        Dim rTemp           As Range
        Dim FindWord()      As String
        Dim ActualSheet     As String:    ActualSheet = ActiveWorkbook.ActiveSheet.Name
        Dim i               As Long:      i = -1
        Dim j               As Long
        Dim k               As Long
        Dim z               As Long
        Dim oSheet          As Worksheet
        
        ReDim FindWord(Sheets.Count - 1, 1000, 1000)
        
    For Each oSheet In ActiveWorkbook.Worksheets
        i = i + 1:      j = 1:      k = 1
        
        FindWord(i, 0, 0) = CStr(oSheet.Name)
        oSheet.Select: Range("A1").Select
    
        Cells.Find(sWord).Activate
        Debug.Print ActiveCell.Address
        'Cells.FindNext(ActiveCell).Activate   '  ---> si je le fais ICI, c'est OK, il
                                                '       me trouve bien la cellule suivante
        'Debug.Print ActiveCell.Address
            
        FindWord(i, k, 0) = ActiveCell.Row: Set rStartCell = ActiveCell
        
        For z = 1 To LastColumn(ActiveCell.Row)
            FindWord(i, k, z) = Cells(ActiveCell.Row, z).Value
            Debug.Print Cells(ActiveCell.Row, z).Value
        Next z
        
        Do
            Cells.FindNext(ActiveCell).Activate ' ---> si je le fais ICI, c'est PAS OK, il
                                                '       me fait un OffSet??,  la cellule se décale
                                                '       vers la droite ???  Sais pas pourquoi (pis c'est une cellule vierge)
            Debug.Print ActiveCell.Address
            j = j + 1:      k = k + 1
            
            FindWord(i, k, 0) = ActiveCell.Row
            
            For z = 1 To LastColumn(ActiveCell.Row)
                FindWord(i, k, z) = Cells(ActiveCell.Row, z).Value
                Debug.Print Cells(ActiveCell.Row, z).Value
            Next z
                    
        Loop While ActiveCell.Address <> Range(rStartCell.Address).Address
        
    Next oSheet
    Sheets(ActualSheet).Select
    FindWords = FindWord: Erase FindWord
    
End Function

Sub Exemple_Utilisation()
    Dim sResult() As String
    
    sResult = FindWords("Bruce")
    
    'MsgBox UBound(sResult, 1)
    'MsgBox UBound(sResult, 2)
    'MsgBox UBound(sResult, 3)
    
    
    
    Erase sResult
End Sub

~ <small> Mortalino ~ Colorisation automatique </small>

@++

<hr width ="100%" size="2" />
  --Mortalino--
Le mystérieux chevalier, ~Provençal, le Gaulois~
  
Messages postés
360
Date d'inscription
dimanche 3 décembre 2006
Statut
Membre
Dernière intervention
3 janvier 2012
3
Merci je vais continuer demain, mais j'ai fait une premiere essaie puis voici les résultat:

J'ai mis dans un module:

Function LastColumn(ByVal MyRow As Long) As Integer
    LastColumn =  Rows(MyRow).Find("").Column - 1
End Function

Public Function FindWords(ByVal sWord As String) As String()
        Dim rStartCell      As Range
        Dim rTemp           As Range
        Dim FindWord()      As String
        Dim ActualSheet     As String:    ActualSheet = ActiveWorkbook.ActiveSheet.Name
        Dim i               As Long:      i = -1
        Dim j               As Long
        Dim k               As Long
        Dim z               As Long
        Dim oSheet          As Worksheet
        
        ReDim FindWord(Sheets.Count - 1, 1000, 1000)
        
    For Each oSheet In ActiveWorkbook.Worksheets
        i = i + 1:      j = 1:      k = 1
        
        FindWord(i, 0, 0) = CStr(oSheet.Name)
        oSheet.Select: Range("A1").Select
    
        Cells.Find(sWord).Activate
        Debug.Print ActiveCell.Address
        'Cells.FindNext(ActiveCell).Activate   '  ---> si je le fais ICI, c'est OK, il
                                                '       me trouve bien la cellule suivante
        'Debug.Print ActiveCell.Address
            
        FindWord(i, k, 0) = ActiveCell.Row: Set rStartCell = ActiveCell
        
        For z = 1 To LastColumn(ActiveCell.Row)
            FindWord(i, k, z) = Cells(ActiveCell.Row, z).Value
            Debug.Print Cells(ActiveCell.Row, z).Value
        Next z
        
        Do
            Cells.FindNext(ActiveCell).Activate ' ---> si je le fais ICI, c'est PAS OK, il
                                                '       me fait un OffSet??,  la cellule se décale
                                                '       vers la droite ???  Sais pas pourquoi (pis c'est une cellule vierge)
            Debug.Print ActiveCell.Address
            j = j + 1:      k = k + 1
            
            FindWord(i, k, 0) = ActiveCell.Row
            
            For z = 1 To LastColumn(ActiveCell.Row)
                FindWord(i, k, z) = Cells(ActiveCell.Row, z).Value
                Debug.Print Cells(ActiveCell.Row, z).Value
            Next z
                    
        Loop While ActiveCell.Address <> Range(rStartCell.Address).Address
        
    Next oSheet
    Sheets(ActualSheet).Select
    FindWords = FindWord: Erase FindWord
    
End Function

Puis dans un userform avec un textbox et un bouton:

 Dim sResult() As String
    
    sResult = FindWords("Bruce")
    
    'MsgBox UBound(sResult, 1)
    'MsgBox UBound(sResult, 2)
    'MsgBox UBound(sResult, 3)
    
    
    
    Erase sResult

End Sub

Je rencotre un problème avec:

Public Function FindWords(ByVal sWord As String) As String()
        Dim rStartCell      As Range
        Dim rTemp           As Range
        Dim FindWord()      As String
        Dim ActualSheet     As String:    ActualSheet = ActiveWorkbook.ActiveSheet.Name
        Dim i               As Long:      i = -1
        Dim j               As Long
        Dim k               As Long
        Dim z               As Long
        Dim oSheet          As Worksheet
       
        ReDim FindWord(Sheets.Count - 1, 1000, 1000)
       
    For Each oSheet In ActiveWorkbook.Worksheets        i i + 1:      j 1:      k = 1
       
        FindWord(i, 0, 0) = CStr(oSheet.Name)
        oSheet.Select: Range("A1").Select
   
        Cells.Find(sWord).Activate
        Debug.Print ActiveCell.Address
        'Cells.FindNext(ActiveCell).Activate   '  ---> si je le fais ICI, c'est OK, il
                                                '       me trouve bien la cellule suivante
        'Debug.Print ActiveCell.Address
                    FindWord(i, k, 0) ActiveCell.Row: Set rStartCell ActiveCell

en premier lieu mais bon, merci pour ton aide, je vais regarder ça à tête reposé demain.

Merci pour ton temps et de ton aide.
Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
Beh c'est pas de tout repos en fait, pensais que ce serait simple, mais je galère un peu. (avec le tableau, j'aurai dût prendre une collection, ça aurait été plus simple)
Mais la flemme de recommencer, j'ai modifier selon la base ^^

Pour infos, afin de faire mes test, j'ai pris un fichier avec une liste de Film, la liste est dans Feuil1, je l'ai copié, et coller dans Feuil3.
Ca fonctionne très bien avec la feuil 3, mais pas la 1.
J'ai dût me planter dans les indices, quoi que pas à pas, ça avait l'air de correspondre.

Bref, voici le code, il doit y avoir une erreur bidon que je ne vois pas, si tu la trouve :

Function LastColumn(ByVal MyRow As Long) As Integer
    LastColumn =  Rows(MyRow).Find("").Column - 1
End Function

Public Function FindWords(ByVal sWord As String) As String()
        Dim rStartCell      As Range
        Dim rTemp           As Range
        Dim FindWord()      As String
        Dim ActualSheet     As String
        Dim i               As Long:    i = -1
        Dim j               As Long
        Dim k               As Long
        Dim z               As Long
        Dim B               As Long:    B = -1
        Dim C               As Long:    C = -1
        Dim Max             As Long
        Dim oSheet          As Worksheet

    ActualSheet = ActiveWorkbook.ActiveSheet.Name
        
    For Each oSheet In ActiveWorkbook.Worksheets
        oSheet.Select: Range("IV65536").Select
    
        On Error Resume Next
        Cells.Find(sWord).Activate
        If Not (Err.Number = 91) Then
            'Debug.Print ActiveCell.Address
            
            i = i + 1:      j = 1:      k = 1: B = 1: C = 1
            ReDim Preserve FindWord(Sheets.Count - 1, 1000, C)
            
            FindWord(i, 0, 0) = CStr(oSheet.Name)
            
            ReDim Preserve FindWord(i, B, C)
            FindWord(i, k, 0) = ActiveCell.Row: Set rStartCell = ActiveCell
            
            For z = 1 To LastColumn(ActiveCell.Row)
                C = C + 1
                ReDim Preserve FindWord(Sheets.Count - 1, 1000, C)
                FindWord(i, k, z) = Cells(ActiveCell.Row, z).Value
                'Debug.Print Cells(ActiveCell.Row, z).Value
            Next z
            
            Do
            
                Cells.Find(sWord, Cells(ActiveCell.Row + 1, 1)).Activate
                If ActiveCell.Address = Range(rStartCell.Address).Address Then Exit Do
                'Debug.Print ActiveCell.Address
                j = j + 1:      k = k + 1
                
                B = B + 1
                ReDim Preserve FindWord(Sheets.Count - 1, 1000, C)
                FindWord(i, k, 0) = ActiveCell.Row
                
                Max = LastColumn(ActiveCell.Row)
                For z = 1 To Max
                    C = C + 1
                    ReDim Preserve FindWord(Sheets.Count - 1, 1000, C)
                    FindWord(i, k, z) = Cells(ActiveCell.Row, z).Value
                    'Debug.Print Cells(ActiveCell.Row, z).Value
                    'MsgBox FindWord(i, B, z)
                Next z
                        
            Loop
            ReDim Preserve FindWord(Sheets.Count - 1, 1000, C) '- Max
        End If
    Next oSheet
    
MyEnd:
    Sheets(ActualSheet).Select
    FindWords = FindWord: Erase FindWord
    
End Function

Sub Exemple_Utilisation()
    Dim sResult() As String
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim bVerif As Boolean   ' 0 1 2 = ""
    
    'On Error Resume Next
    sResult = FindWords("Bruce")
    
    
    
    For i = 0 To UBound(sResult, 1)
        If sResult(i, 0, 0) <> vbNullString Then
            Debug.Print "Onglet : " & sResult(i, j, k)
            
            For j = 1 To UBound(sResult, 2)

                If sResult(i, j, 0) <> vbNullString Then
                    Debug.Print "    Ligne : " & sResult(i, j, k)
                    
                    For k = 1 To UBound(sResult, 3)
                        If sResult(i, j, k) <> vbNullString Then
                            Debug.Print "        Données : " & sResult(i, j, k)
                        End If
                    Next k
                    
                    k = 0
                End If
            Next j
            j = 0
        End If
    Next i
    Erase sResult
End Sub

~ <small> Mortalino ~ Colorisation automatique </small>

Le résultat dans la fenêtre execution :

Onglet : Feuil1
    Ligne : 8
        Données : ARMAGEDDON
    Ligne : 16
        Données : BANDITS
    Ligne : 76
        Données : HUDSON HAWK
    Ligne : 99
        Données : L'ARMEE DES 12 SINGES
    Ligne : 104
        Données : LE CHACAL
    Ligne : 105
        Données : LE DERNIER SAMARITAIN
    Ligne : 120
        Données : LES CONTES DE LA CRYPTE  Vol. 1
    Ligne : 144
        Données : MON VOISIN LE TUEUR    (copie)
Onglet : Feuil3
    Ligne : 8
        Données : ARMAGEDDON
        Données : Film
        Données : Michael Bay
        Données : Bruce Willis, Liv Tyler, Ben Affleck,…
    Ligne : 16
        Données : BANDITS
        Données : Film
        Données : Barry Levinson
        Données : Bruce Willis, Billy Bob Thornton,…
    Ligne : 76
        Données : HUDSON HAWK
        Données : Film
    Ligne : 99
        Données : L'ARMEE DES 12 SINGES
        Données : Film
        Données : Terry Gilliam
        Données : Bruce Willis, Brad Pitt, Madeleine Stowe,.
    Ligne : 104
        Données : LE CHACAL
        Données : Film
        Données : Michael Caton-Jones
        Données : Richard Gere, Bruce Willis,…
    Ligne : 105
        Données : LE DERNIER SAMARITAIN
        Données : Film
        Données : Tony Scott
        Données : Bruce Willis, Damon Wayans,…
    Ligne : 120
        Données : LES CONTES DE LA CRYPTE  Vol. 1
        Données : Série
        Données : Divers
        Données : Steven Weber, Bruce Boxleitner,…
    Ligne : 144
        Données : MON VOISIN LE TUEUR    (copie)
        Données : Film






@++





<hr width ="100%" size="2" />

  --Mortalino--
Le mystérieux chevalier, ~Provençal, le Gaulois~
  
Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
J'aime pas la méthode Find, je suis sûr qu'en passant outre, je peux réduire le code ^^
J'essaierai demain avec mes collections et For Each Cell in UsedRange
Ce sera à coup sûr plus rapide et performant que le tableau pourr** que j'ai fait (et les milliards de boucles)

@++

<hr width="100%" size="2" />
  --Mortalino--
Le mystérieux chevalier, ~Provençal, le Gaulois~
  
Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
Tiens, cette version à été rapide à faire. Pourquoi faire très compliqué quand on peut faire simple

Ca devrait fonctionner nickel :

Const sSeparator =  "[SEPARATOR]"

Function LastColumn(ByVal MyRow As Long) As Integer
    LastColumn = Rows(MyRow).Find("").Column - 1
End Function

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
        
    ActualSheet = ActiveWorkbook.ActiveSheet.Name
        
    For Each oSheet In ActiveWorkbook.Worksheets
        oSheet.Select: Range("IV65536").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).Value)
            Next z
            
            FindWord(i) = SheetName & sSeparator & NumRow & Datas
            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
                    Datas = Datas & sSeparator & CStr(Cells(ActiveCell.Row, z).Value)
                Next z
                FindWord(i) = SheetName & sSeparator & NumRow & Datas
                i = i + 1
            Loop
        End If
    Next oSheet
    
MyEnd:
    Sheets(ActualSheet).Select
    FindWords = FindWord: Erase FindWord
    
End Function

Sub Exemple_Utilisation()
    Dim sResult()       As String
    Dim ParseResult()   As String
    Dim i As Long
    Dim j As Long
    
    sResult = FindWords("Bruce")
    
    For i = LBound(sResult) To UBound(sResult)
        ParseResult = Split(sResult(i), sSeparator)
        For j = LBound(ParseResult) To UBound(ParseResult)
            Debug.Print ParseResult(j)
        Next j
    Next i
    Erase sResult, ParseResult
End Sub

~ <small> Mortalino ~ Colorisation automatique </small>

@++

<hr width ="100%" size="2" />
  --Mortalino--
Le mystérieux chevalier, ~Provençal, le Gaulois~
  
Messages postés
6786
Date d'inscription
vendredi 16 décembre 2005
Statut
Membre
Dernière intervention
21 décembre 2011
18
C'est bon pour toi

@++

<hr width="100%" size="2" />
  --Mortalino--
Le mystérieux chevalier, ~Provençal, le Gaulois~
  
Messages postés
3877
Date d'inscription
mardi 19 mars 2002
Statut
Membre
Dernière intervention
23 août 2018
18
Voici comment je procéderais avec Find et FindNext
Un UserForm avec un textbox, un bouton de commande et un listbox

On commence par afficher le UserForm
Sur celui-ci, on inscrit la valeur dans le textbox et on clique le bouton
2 résultats sont créés; affichage dans le listbox et construction d'un tableau dynamique
Mais le tout s'affiche d'un seul coup sans utilisation de bouton Suivant. Si ce bouton est nécessaire, il faudrait inclure une boucle à l'intérieur du Do Loop, juste avant de refaire une recherche (en bleu).

Donc, tu affiches le premier résultat et tu boucles, du genre
Do
    DoEventsLoop Until VariableContinuer True or VariableArret True

Et tu utilises 2 boutons pour
"Suivant" qui met la variable à True
"Arret" qui met sa variable à True
Après vérification des variables, tu sors ou tu continues et tu remets les variables à False
(hummm pas sûr d'être bien clair là-dessus... si ce ne l'est pas je ferai ce petit bout)

Option Explicit

Private Sub CommandButton1_Click()
    RechercheMultiple TextBox1.Text
End Sub

Sub RechercheMultiple(Valeur As String)
    Dim Recherche As Range  'variable objet de recherche
    Dim Adresse As String   'stocke la première adresse trouvée dans une feuille
    Dim Idx As Integer      'Index pour le tableau
    Dim Feuille As Worksheet
    Dim Tablo() As String
    Dim Trouvé As Boolean   'juste pour savoir si une valeur a été trouvée
   
    Idx = -1        'Index de départ pour le tableau
    ReDim Tablo(0)  'initialise le tablo dynamique
    ListBox1.Clear  'vide le listbox pour une nouvelle recherche
   
    'Lecture de chaque feuille
    For Each Feuille In Worksheets
        Feuille.Activate
        Set Recherche = Cells.Find(Valeur, , xlValues, xlWhole)
        If Not Recherche Is Nothing Then  'trouvé
            Trouvé = True
            'on stocke la première adresse pour éviter de la ressortir
            Adresse = Recherche.Address
            Do
                'Stocker dans un tableau au besoin
                Idx = Idx + 1
                ReDim Preserve Tablo(Idx)
                Tablo(Idx) = ActiveSheet.Name & ": " & Recherche.Address
                'inscrire dans une listbox au besoin
                ListBox1.AddItem ActiveSheet.Name & ": " & Recherche.Address
                'Continuer la recherche
                Set Recherche = Cells.FindNext(Recherche)
            'on recommence si une valeur est trouvée pour la première fois
            Loop While Not Recherche Is Nothing And Recherche.Address <> Adresse
        End If
    Next
   
    If Not Trouvé Then MsgBox "La valeur n'existe pas"
   
End Sub

MPi
Messages postés
360
Date d'inscription
dimanche 3 décembre 2006
Statut
Membre
Dernière intervention
3 janvier 2012
3
Merci mortalinos,

Juste pour être sure, je met dans un module cette partie:

Const sSeparator = "[SEPARATOR]"

Function LastColumn(ByVal MyRow As Long) As Integer
    LastColumn = Rows(MyRow).Find("").Column - 1
End Function

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
        
    ActualSheet = ActiveWorkbook.ActiveSheet.Name
        
    For Each oSheet In ActiveWorkbook.Worksheets
        oSheet.Select: Range("IV65536").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).Value)
            Next z
            
            FindWord(i) = SheetName & sSeparator & NumRow & Datas
            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
                    Datas = Datas & sSeparator & CStr(Cells(ActiveCell.Row, z).Value)
                Next z
                FindWord(i) = SheetName & sSeparator & NumRow & Datas
                i = i + 1
            Loop
        End If
    Next oSheet
    
MyEnd:
    Sheets(ActualSheet).Select
    FindWords = FindWord: Erase FindWord
    
End Function

<hr size="2" width="100%" />

Et Je crée un userform avec un textbox et un bouton, puis je met dans le bouton:

Sub Exemple_Utilisation()
    Dim sResult()       As String
    Dim ParseResult()   As String
    Dim i As Long
    Dim j As Long
    
    sResult = FindWords("Bruce")
    
    For i = LBound(sResult) To UBound(sResult)
        ParseResult = Split(sResult(i), sSeparator)
        For j = LBound(ParseResult) To UBound(ParseResult)
            Debug.Print ParseResult(j)
        Next j
    Next i
    Erase sResult, ParseResult
End Sub

<hr size="2" width="100%" />

Est-ce bien ça?