Boite Recherche de mot dans fichier excel VBARésolu

Question

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

mortalino · Accepted Answer

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~

avyrex1926 · Answer

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 !!!!

mortalino · Answer

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~

avyrex1926 · Answer

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 ?

mortalino · Answer

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~

avyrex1926 · Answer

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?

mortalino · Answer

Non, c'est facile à faire, je regarde ça de suite.

@++ 

<hr width="100%" size="2" />
  --Mortalino--
Le mystérieux chevalier, ~Provençal, le Gaulois~

avyrex1926 · Answer

merci

mortalino · Answer

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 ~ Mortalino ~ Colorisation automatique @++

--Mortalino-- Le mystérieux chevalier, ~Provençal, le Gaulois~

avyrex1926 · Answer

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.

mortalino · Answer

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 ~ Mortalino ~ Colorisation automatique 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 @++

--Mortalino-- Le mystérieux chevalier, ~Provençal, le Gaulois~

mortalino · Answer

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~

mortalino · Answer

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 ~ Mortalino ~ Colorisation automatique @++

--Mortalino-- Le mystérieux chevalier, ~Provençal, le Gaulois~

mortalino · Answer

C'est bon pour toi 

@++ 

<hr width="100%" size="2" />
  --Mortalino--
Le mystérieux chevalier, ~Provençal, le Gaulois~

cs_MPi · Answer

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

avyrex1926 · Answer

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

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

Est-ce bien ça?

mortalino · Answer

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 ~ Mortalino ~ Colorisation automatique @++

--Mortalino-- Le mystérieux chevalier, ~Provençal, le Gaulois~

mortalino · Answer

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~

mortalino · Answer

Décidemment,.. (désolé) fait l'inverse ici : ~~For i = 1 To~~ ~~NoDupes.Count~~ For i = NoDupes.Count To 1 Step -1 NoDupes.Remove (i) Next i @++

--Mortalino-- Le mystérieux chevalier, ~Provençal, le Gaulois~

mortalino · Answer

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~

Boite Recherche de mot dans fichier excel VBA

28 réponses

Votre réponse

Discussions similaires