Recherche mot clé puis afficher la ligne sur une autre feuille

Bonjour,

Je tente désespérément de rajouter à mon Excel une fonctionnalité de recherche auto en fonction d 'un mot clé contenu dans toutes les cellules spécifiées sur une feuille source puis de coller toutes les lignes correspondantes sur une autre feuille cible.

Voici le code que j ai récupérer sur le net et que j ai tenté d'adapter:

Sub CutData()

Dim sStr As String, Cell As Range, rng As Range

sStr = "#member#"

For Each Cell In Worksheets("Brute").Range("H13:H30")

If InStr(1, sStr, Cell.Value, vbTextCompare) > 0 Then

If rng Is Nothing Then

Set rng = Cell

Else

Set rng = Union(rng, Cell)

End If

End If

Next

If Not rng Is Nothing Then

rng.EntireRow.Copy Destination:=Worksheets("METEO").Range("A35")

End If

End Sub

Feuille Source "Brute"

Feuille Cible souhaitée "METEO"

Mon soucis: peu importe si le mot clé est trouvé...cela m affiche toutes les lignes de ma feuille source (H13:H30)

Pouvez vous m aider svp ??

Merci

Salut lacrouts,

Bienvenue parmi nous.

Un petit fichier explicatif est toujours un plus pour recevoir rapidement des réponses adéquates.

A+

Bonjour,

Essayer ce code

Sub CutData()

    Dim sStr As String, cell As Range, cell1 As Range, lignes_à_copier As Range

    sStr = "#member#"

    With Sheets("Brute").Range("H13:H30")
        Set cell = .Find(sStr)
        If Not cell Is Nothing Then
            Set cell1 = cell
            Do
                If lignes_à_copier Is Nothing Then Set lignes_à_copier = cell.EntireRow _
                Else Set lignes_à_copier = Union(lignes_à_copier, cell.EntireRow)
                Set cell = .FindNext(cell)
            Loop Until cell.Address = cell1.Address
        End If
    End With

    If Not lignes_à_copier Is Nothing Then lignes_à_copier.Copy Destination:=Sheets("METEO").Range("A35")

End Sub

Ça fonctionne !! Tip top !! un grand merci !!

J'ai juste modifié

"#member#"

par

"*member*"

car cela ne fonctionnait pas.

Je souhaiterai également, si possible, en fonction d 'un autre mot clé, non pas sortir la ligne entière sur la feuille cible "METEO" mais uniquement la colonne "A" "B" et "C" de ma feuille source.

Est ce possible facilement sans changement majeur du code proposé ?

Merci

lacrouts a écrit :

Je souhaiterai également, si possible, en fonction d 'un autre mot clé, non pas sortir la ligne entière sur la feuille cible "METEO" mais uniquement la colonne "A" "B" et "C" de ma feuille source.

ci-dessous modification code

Sub CutData()

    Dim sStr As String, cell As Range, cell1 As Range, lignes_à_copier As Range

    sStr = "*member*"

    With Sheets("Brute")
        Set cell = .Range("H13:H30").Find(sStr)
        If Not cell Is Nothing Then
            Set cell1 = cell
            Do
                If lignes_à_copier Is Nothing Then Set lignes_à_copier = .Columns("A:C").Rows(cell.Row) _
                Else Set lignes_à_copier = Union(lignes_à_copier, .Columns("A:C").Rows(cell.Row))
                Set cell = .Range("H13:H30").FindNext(cell)
            Loop Until cell.Address = cell1.Address
        End If
    End With

    If Not lignes_à_copier Is Nothing Then lignes_à_copier.Copy Destination:=Sheets("METEO").Range("A35")

End Sub

Juste parfait !!!

Merci beaucoup pour ton aide thev !!!

Je reviens a ce sujet car j ai un petit soucis esthétique...

En effet ma feuille cible dispose d une mise en forme.

Est il possible de dire a "lignes_à_copier.Copy" de respecter la mise en forme des cellules cibles ??

Merci

Bonjour,

il suffit de modifier la dernière instruction comme ceci

If Not lignes_à_copier Is Nothing Then lignes_à_copier.Copy: Sheets("METEO").Range("A35").PasteSpecial (xlPasteFormulas)

It works !! Merci!

Maintenant autre soucis:

au départ de ce code, j aimerai nettoyer les valeurs, si existantes, (en gardant la mise en forme de destination) sur ma feuille cible

J ai donc essayé:

Sub CutData()

    Dim sStr As String, cell As Range, cell1 As Range, lignes_à_copier As Range

    sStr = "*member*"

    Sheets("METEO").Range("A35:F52").Cells.Clear

    With Sheets("Brute")
        Set cell = .Range("H13:H30").Find(sStr)
        If Not cell Is Nothing Then
            Set cell1 = cell
            Do
                If lignes_à_copier Is Nothing Then Set lignes_à_copier = .Columns("A:C").Rows(cell.Row) _
                Else Set lignes_à_copier = Union(lignes_à_copier, .Columns("A:C").Rows(cell.Row))
                Set cell = .Range("H13:H30").FindNext(cell)
            Loop Until cell.Address = cell1.Address
        End If
    End With

    If Not lignes_à_copier Is Nothing Then lignes_à_copier.Copy: Sheets("METEO").Range("A35").PasteSpecial (xlPasteFormulas)

End Sub

Sauf que le code que j ai ajouté:

   Sheets("METEO").Range("A35:F52").Cells.Clear

Supprime la mise en forme de destination

Comment la conserver ??

ah je viens de trouver c'est plutôt le code :

Sheets("METEO_SAN").Range("A47:F48").Cells.ClearContents

qui permet de faire ça.

L'ajout de la propriété "cells" est inutile

Sheets("METEO_SAN").Range("A47:F48").ClearContents