Fonction recherche dans database puis extraction

Bonjour à tous,

Je suis en train de remplir une database et on m'a demandé de faire un outil de recherche par mot clé en vba.

Je sais que le sujet a déjà été traité mais mes connaissance ne me permettent même pas d'adapter les codes déjà existant (oui, j'ai un peu honte).

Ce serait super chouette si quelqu'un pouvait se pencher sur mon problème

Description de la macro :

l'utilisateur renseigne la case C3 de la feuille "Recherche" avec le mot clé qu'il recherche.

La macro trouve alors toutes les ligne où se trouve ce mot clé dans la Feuille "Database"

et copie ensuite le résultat de la recherche sur le feuille "Recherche".

Je vous remercie pas avance,

Bonjour

D'abord dans la feuille Recherche, il faut défusionner les cellules où tu vas mettre le nom pour le critère de recherche. Il y a toujours des soucis avec les fusions de cellules lorsque l'on fait appel à du code.

Là tu as fusionné depuis C3 à D4. Utilise C3 seul.

Ensuite remplace le code que tu as par celui-ci-dessous :

Sub recherche()
' Déclaration des variables
Dim sMotRecherche As String
Dim Resultat As Range, plage As Range, cel As Range
Dim prim
' Définition de la chaîne recherchée dans la cellule C3 de la feuille "Recherche"
sMotRecherche = Sheets("Recherche").Range("C3").Value

' Définition de la plage dans laquelle on effectue la recherche; ici colone D de la feuille "Database"
Set plage = Sheets("Database").Range("D2:D" & Sheets("Database").Range("D65536").End(xlUp).Row)

' Recherche de "sMotRecherche" dans "Plage"
With plage
    Set cel = .Find(sMotRecherche, LookIn:=xlValues)
    If Not cel Is Nothing Then
        prim = cel.Address
        Do
            Sheets("Database").Range("A" & cel.Row & ":D" & cel.Row).Copy Sheets("Recherche").Range("C" & Sheets("Recherche").Range("C" & Sheets("Recherche").Rows.Count).End(xlUp).Row + 1)
            Set cel = .FindNext(cel)
        Loop While Not cel Is Nothing And cel.Address <> prim
    End If
End With
End Sub

Si ok, lors de ta réponse merci de cloturer le fil en cliquant sur le V vert àcoté du bouton EDITER

Amicalement

Merci beaucoup Dan, cela fonctionne parfaitement !

j'ai ajouté quelques modifications :

La recherche s'effectue aussi dans la colonne "D" qui contient des observations.

Nettoyage de la zone où sont afficher les résultats.

je poste le fichier final au cas où quelqu'un en aurait besoin.

Je voudrais maintenant mettre le mot recherché en valeur au niveau de l'affichage du résultat.

Voici un début de code pour le faire :

Sub Mise_en_valeur()

    Dim FL1 As Worksheet, Cell As Range, Plage As Range
    Dim mot_cible As String, target As String

    Set FL1 = Worksheets("Recherche")
    With FL1
        'Détermination de la plage de cellules à lire
        Set Plage = .Range("E" & .Range("H65536").End(xlUp).Row)
        mot_cible = Range("E3").Value

        For Each Cell In Plage
            'Parcours "Cell" et change la couleur du mot cible
            'If Cell.Count > 1 Then Exit Sub
            If LCase(Cell.Value) Like "*" & mot_cible & "*" Then
                With Cell.Characters(InStr(Cell, mot_cible), Len(mot_cible)).Font
                    .ColorIndex = 3
                    .Bold = True
                End With
            End If
        Next
    End With
End Sub

Le hic c'est qu'il parcours bien ma range, l'analyse mais ne change pas la couleur du mot_cible partout.

Je pense que c'est tout con, mais je ne vois pas

Merci d'avance,

Bonjour à tous,

solution trouvée :

Sub MiseEnValeur()
'texte en gras et rouge
Dim LeMot As String
Dim plage As Range

LeMot = Range("E3").Value
Set plage = Range("E9:H" & Range("H65536").End(xlUp).Row)

If LeMot = "" Then Exit Sub

For Each cel In plage
    Set fc = cel.Find(what:=LeMot)
    If fc Is Nothing Then GoTo suite

    n1 = InStr(1, cel, LeMot, 1)
 code = LeMot
 For i = n1 To Len(code) + n1 - 1
     car = Mid(cel, i, 1)
     With cel.Characters(Start:=i, Length:=1).Font
     .ColorIndex = 3
     .Bold = True
     End With
 Next

suite:
Next

End Sub

J'espère que cela vous sera utile !!!!!

J'ai joint également la dernière version du fichier :