Sujet Précédent Sujet Suivant

Problème fonction recherche vba

Résolu
avyrex1926 Messages postés 360 Date d'inscription dimanche 3 décembre 2006 Statut Membre Dernière intervention 3 janvier 2012 - 27 juil. 2007 à 23:10
cs_MPi Messages postés 3877 Date d'inscription mardi 19 mars 2002 Statut Membre Dernière intervention 17 août 2018 - 28 juil. 2007 à 18:22
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

Réponse 1 / 27
cs_MPi Messages postés 3877 Date d'inscription mardi 19 mars 2002 Statut Membre Dernière intervention 17 août 2018 22
28 juil. 2007 à 17:09
Comme tu veux remplir une listbox, tu n'as plus besoin d'utiliser un séparateur.
Je ne passe pas le contrôle Listbox en paramètre, mais ça pourrait être fait.

Private Sub CommandButton1_Click()
    RechercheMot TextBox1.Text
    If ListBox1.ListCount = 0 Then ListBox1.AddItem "Aucune valeur trouvée"
End Sub

Sub RechercheMot(Mot As String)
    Dim I As Long, nbItems As Long, nbColonnes As Integer
    Dim Recherche As Range, Adresse As String
   
    UserForm1.ListBox1.Clear
    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
           
            'Lire la ligne
            UserForm1.ListBox1.AddItem Space(8) & "LIGNE : " & Recherche.Row
            For I = 1 To nbColonnes
                UserForm1.ListBox1.AddItem Cells(Recherche.Row, I)
            Next
            UserForm1.ListBox1.AddItem  'insère un espace
           
            Set Recherche = Columns("G").FindNext(Recherche)
        Loop Until Recherche.Address = Adresse Or Recherche Is Nothing
    End If
   
End Sub

MPi
3
Réponse 2 / 27
mortalino Messages postés 6786 Date d'inscription vendredi 16 décembre 2005 Statut Membre Dernière intervention 21 décembre 2011 18
27 juil. 2007 à 23:49
c'est pas mon code ça ?

Salut Avyrex, et bien qu'est ce qui t'empêche de ne le faire que dans une seule feuille ?
Quand tu dis "mais juste dans la basse de données.", c'est donc la feuille en cours ?

@++

<hr size="2" width="100%" />( Nouveau forum : Exclusivement Office & VBA
0
Réponse 3 / 27
avyrex1926 Messages postés 360 Date d'inscription dimanche 3 décembre 2006 Statut Membre Dernière intervention 3 janvier 2012 3
28 juil. 2007 à 00:09
Salut mortalino,

et oui, c'est ton super code qui fonctionne mais je veux juste qu'il recherche dans la feuille en cours. 
0
Réponse 4 / 27
mortalino Messages postés 6786 Date d'inscription vendredi 16 décembre 2005 Statut Membre Dernière intervention 21 décembre 2011 18
28 juil. 2007 à 00:17
rhaa le vieux code :D
voici la fonction juste pour la feuille en cours :

Option Explicit

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 NumRow          As String
        Dim Datas           As String
       
        '************************************
        Dim NoDupes         As New Collection
        '************************************
       
        Range("U65536").Select

            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) = 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) = NumRow & sSeparator & Datas &
sSeparator
                i = i + 1
            Loop
        End If

    FindWords = FindWord: Erase FindWord

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

'*************************
End Function

~
<small>[code.aspx?ID=39466 Mortalino] ~
Colorisation automatique</small>

@++

<hr size="2" width="100%" />( Nouveau forum : Exclusivement Office & VBA
0

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Réponse 5 / 27
avyrex1926 Messages postés 360 Date d'inscription dimanche 3 décembre 2006 Statut Membre Dernière intervention 3 janvier 2012 3
28 juil. 2007 à 00:26
Merci encore pour ton aide 
0
Réponse 6 / 27
avyrex1926 Messages postés 360 Date d'inscription dimanche 3 décembre 2006 Statut Membre Dernière intervention 3 janvier 2012 3
28 juil. 2007 à 01:24
Petite question encore,

Il semble que les info se répete plusieurs fois dans la liste quand je fait la recherche au lieu de l'ecrire qu'une seul fois.

Ex:

                   Ligne 60
PB
5656
Alain
Rona
Pinceau
2$

                     Ligne 90

PB

5656

Alain

Rona

Pinceau

2$


PB
5678
Sylvain


Rona
Tableau
54$

Pourquoi la recherche double les résultat?
0
Réponse 7 / 27
mortalino Messages postés 6786 Date d'inscription vendredi 16 décembre 2005 Statut Membre Dernière intervention 21 décembre 2011 18
28 juil. 2007 à 01:30
heu ? Qu'y a-t-il en double ?

Ligne 90, ce qui est en gras et en dessous sont différents

@++

<hr size="2" width="100%" />( Nouveau forum : Exclusivement Office & VBA
0
Réponse 8 / 27
avyrex1926 Messages postés 360 Date d'inscription dimanche 3 décembre 2006 Statut Membre Dernière intervention 3 janvier 2012 3
28 juil. 2007 à 01:38
Ligne 90 = la ligne 60 + la ligne 90

Je comprend pas pourquoi
0
Réponse 9 / 27
mortalino Messages postés 6786 Date d'inscription vendredi 16 décembre 2005 Statut Membre Dernière intervention 21 décembre 2011 18
28 juil. 2007 à 01:42
j'ai du mal a me représenter..

Quel est le mot mis en paramètre de recherche pour ce cas ?
Comment sont positionnées exactement ces données dans tes cellules ?

@++

<hr size="2" width="100%" />( Nouveau forum : Exclusivement Office & VBA
0
Réponse 10 / 27
mortalino Messages postés 6786 Date d'inscription vendredi 16 décembre 2005 Statut Membre Dernière intervention 21 décembre 2011 18
28 juil. 2007 à 01:45
vérifie ta ligne 90, qu'il n'y ait pas de données cachées ou dans les colonnes plus à droite

@++

<hr size="2" width="100%" />( Nouveau forum : Exclusivement Office & VBA
0
Réponse 11 / 27
avyrex1926 Messages postés 360 Date d'inscription dimanche 3 décembre 2006 Statut Membre Dernière intervention 3 janvier 2012 3
28 juil. 2007 à 01:49
le mots en recherche est: Rona

et se qui sort comme recherche est:

                   Ligne 60
PB
5656
Alain
Rona
Pinceau
2$

                     Ligne 90
PB
5656
Alain
Rona
Pinceau
2$

PB
5678
Sylvain
Rona
Tableau
54$

et pourtant, il n'y à rien de caché dans ses ligne
0
Réponse 12 / 27
mortalino Messages postés 6786 Date d'inscription vendredi 16 décembre 2005 Statut Membre Dernière intervention 21 décembre 2011 18
28 juil. 2007 à 02:00
uoi, tu as raison, je regarde ça !

@++

<hr size="2" width="100%" />( Nouveau forum : Exclusivement Office & VBA
0
Réponse 13 / 27
avyrex1926 Messages postés 360 Date d'inscription dimanche 3 décembre 2006 Statut Membre Dernière intervention 3 janvier 2012 3
28 juil. 2007 à 02:01
Je crois qu'a la première celule vide, il coupe les info.

Comment faire pour qu'il me donne les info par défaut de la colone A à Z de chaque ligne dond le mots recherché se trouve sur la ligne
0
Réponse 14 / 27
mortalino Messages postés 6786 Date d'inscription vendredi 16 décembre 2005 Statut Membre Dernière intervention 21 décembre 2011 18
28 juil. 2007 à 02:18
Trouvé, manquait une phrase (en commentaire), j'en ai profité pour une chose, supprime la fonction LastColumn, plus besoin. J'ai aussi supprimé la variable Max :

Option Explicit

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 NumRow          As String
        Dim Datas           As String
        Dim sSeparator      As String: sSeparator = vbCrLf
       
        '************************************
        Dim NoDupes         As New Collection
        '************************************
       
        Range("U65536").Select

            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 ActiveCell.End(xlToRight).Column
                Datas = Datas & sSeparator & CStr(Cells(ActiveCell.Row,
z).Text)
            Next z
            
            FindWord(i) = 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
                Datas = vbNullString ' MANQUAIT CA ICI
###############################
                NumRow = Space(8) & "LIGNE : " & Str$(ActiveCell.Row)
                    ReDim Preserve FindWord(i)
                For z = 1 To ActiveCell.End(xlToRight).Column
               
                '*******************************************
                    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) = NumRow & sSeparator & Datas &
sSeparator
                i = i + 1
            Loop
        End If

    FindWords = FindWord: Erase FindWord

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

'*************************
End Function

Sub test()
    Dim aa() As String, i As Long
    
aa() = FindWords("Rona")

For i = LBound(aa) To UBound(aa)
    Debug.Print aa(i)
Next i

End Sub

~
<small>[code.aspx?ID=39466 Mortalino] ~
Colorisation automatique</small>

@++

<hr size="2" width="100%" />( Nouveau forum : Exclusivement Office & VBA
0
Réponse 15 / 27
avyrex1926 Messages postés 360 Date d'inscription dimanche 3 décembre 2006 Statut Membre Dernière intervention 3 janvier 2012 3
28 juil. 2007 à 02:34
oups,

maintenant il me donne plein de ligne un en dessous de l'autre avec le signe de TAB

ex:

Ligne 60¶PB¶5656¶123456¶Rona¶
Ligne 68¶PB¶5662¶
Ligne 82¶
Ligne 99¶
Ligne 103¶
Ligne104¶
Ligne 126¶
Ligne 139¶
Ligne 175¶
0
Réponse 16 / 27
mortalino Messages postés 6786 Date d'inscription vendredi 16 décembre 2005 Statut Membre Dernière intervention 21 décembre 2011 18
28 juil. 2007 à 02:38
normal, j'ai mis :
        Dim sSeparator      As String: sSeparator = vbCrLf
utilise celui que t'avais avant (donc supprime cette ligne dans ma fonction)

@++

<hr size="2" width="100%" />( Nouveau forum : Exclusivement Office & VBA
0
Réponse 17 / 27
avyrex1926 Messages postés 360 Date d'inscription dimanche 3 décembre 2006 Statut Membre Dernière intervention 3 janvier 2012 3
28 juil. 2007 à 02:46
oui mais si par exemple:
ex:

Ligne 60¶PB¶5656¶123456¶Rona¶
Ligne 68¶PB¶5662¶
Ligne 82¶
Ligne 99¶
Ligne 103¶
Ligne104¶
Ligne 126¶
Ligne 139¶
Ligne 175¶

Dans la base de donnée, ok pour la ligne 60 avec les bonne infos.
La ligne 68 il manque la suite des infos.
La ligne 82, pas d'info du tout.
Mais pourtant, dans la base de donnée, il y a pourtant des info de la colone A à U.

C'est ça que je comprend pas.
0
Réponse 18 / 27
avyrex1926 Messages postés 360 Date d'inscription dimanche 3 décembre 2006 Statut Membre Dernière intervention 3 janvier 2012 3
28 juil. 2007 à 03:08
Je vais tenter d'expliquer en détail se que je voudrais faire.

Ma recherche se fais de la colone A à Z de chaques lignes. Si par exemple je recherche le Mots RONA dans la liste, mëme s'il y a une celule vide disons dans la colone E de la ligne disons 60, les infos pourais me sortir dans mon ListBox1 comme suis:

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

PB     'Colone A
4556    'Colone B
PB45561    'Colone C
29/03/2007    'Colone D
29/03/2007    'Colone E
54660    'Colone F
RONA REGIONAL LONGUEUIL    'Colone G
5646    'Colone H
18    'Colone I
Sébastien Gauthier    'Colone J
9    'Colone K
2    'Colone L
Rouleau 9" époxy    'Colone M
                 'Colone N
                 'Colone O
                 'Colone P
2     'Colone Q
                 'Colone R
                 'Colone S
Fermé     'Colone T  etc...

         Ligne 90
et ainsi de suite.....

Donc il me donnerais tout les infos de la ligne si se trouve le mots recherché.

<col style =\"width: 63pt;\" width=\"84\" /><col />----
29/03/2007
0
Réponse 19 / 27
mortalino Messages postés 6786 Date d'inscription vendredi 16 décembre 2005 Statut Membre Dernière intervention 21 décembre 2011 18
28 juil. 2007 à 03:14
Tiens, j'ai vraiment codé la fonction comme un sauvage, et donc pour réparer, c'est chiant, j'aurai pu éviter la collection, c'était question de facilité. Bref, voici une énième modif :

(déplacé la méthode Add de la collection)

Option Explicit

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 NumRow          As String
        Dim Datas           As String
        Dim sSeparator      As String: sSeparator = vbCrLf
       
        '************************************
        Dim NoDupes         As New Collection
        '************************************
       
        Range("U65536").Select

            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 ActiveCell.End(xlToRight).Column
                Datas = Datas & sSeparator & CStr(Cells(ActiveCell.Row,
z).Text)
            Next z
            
            FindWord(i) = 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
                Datas = vbNullString
                NumRow = Space(8) & "LIGNE : " & Str$(ActiveCell.Row)
                    ReDim Preserve FindWord(i)
                For z = 1 To ActiveCell.End(xlToRight).Column
               
                    Datas = Datas & sSeparator & CStr(Cells(ActiveCell.Row,
z).Text)
                Next z
                '*******************************************
                    NoDupes.Add Cells(ActiveCell.Row, z).Value, CStr(Cells(ActiveCell.Row,
z).Text)
                    If Err.Number = 457 Then Err.Clear
                    '*******************************************
                FindWord(i) = NumRow & sSeparator & Datas &
sSeparator
                i = i + 1
            Loop
        End If

    FindWords = FindWord: Erase FindWord

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

'*************************
End Function

~
<small>[code.aspx?ID=39466 Mortalino] ~
Colorisation automatique</small>

@++

<hr size="2" width="100%" />( Nouveau forum : Exclusivement Office & VBA
0
Réponse 20 / 27
avyrex1926 Messages postés 360 Date d'inscription dimanche 3 décembre 2006 Statut Membre Dernière intervention 3 janvier 2012 3
28 juil. 2007 à 14:58
Mortalino,

Si je veux avoir le résultat un en dessous de l'autre au lieux de un à coté de l'autres séparrer par un ¶, et apres , avec un espace entre les lignes pour bien visualiser la nouvelle ligne et ses données, y a-t-il beaucoup à changer dans le script?

exemple:
                                       Ligne 60
PB     'Colone A
4556    'Colone B
PB45561    'Colone C
29/03/2007    'Colone D
29/03/2007    'Colone E
54660    'Colone F
RONA REGIONAL LONGUEUIL    'Colone G
5646    'Colone H
18    'Colone I
Sébastien Gauthier    'Colone J
9    'Colone K
2    'Colone L
Rouleau 9" époxy    'Colone M
                 'Colone N
                 'Colone O
                 'Colone P
2     'Colone Q
                 'Colone R
                 'Colone S
Fermé     'Colone T  etc...

                                              Ligne 90
PB     'Colone A

4566   'Colone B

PB45661    'Colone C
30/03/2007    'Colone D
30/03/2007    'Colone E
64852    'Colone F

RONA REGIONAL LONGUEUIL    'Colone G

5646    'Colone H

18    'Colone I

Sébastien Gauthier    'Colone J
8    'Colone K
7    'Colone L
Pinceau    'Colone M

                 'Colone N

                 'Colone O

                 'Colone P
9     'Colone Q

                 'Colone R

                 'Colone S

Fermé     'Colone T  etc...
0
Rejoignez-nous