Macro Excel Recherche d'une valeur et copie de ligne

Le 18/11/2013 à 10:24

Bonjour,

Je souhaite créer une macro qui réaliserai les actions suivantes:

J'ai un fichier Excel avec beaucoup d'onglets.

  • Lorsque je lance la macro, celle-ci me demande quelle valeur rechercher.
  • Puis la macro recherche cette valeur dans toutes les cellules de tous les onglets.
  • Lorsque la valeur est trouvée, la ligne entière contenant cette valeur est recopiée dans un nouveau fichier excel.
Je n'ai jamais programmé de Macro et j'ai seulement quelques notions de programmations générales.

Voici le début de ma macro:

Sub Macro1()
Dim resultat As String

    resultat = InputBox("Entrer numéro de LIO :", "Titre") 'La variable reçoit la valeur entrée dans l'InputBox

    If resultat <> "" Then 'Si la valeur est différente de "" on affiche le résultat
       MsgBox "Le LIO recherché est " & resultat
    End If

Set trouve = Sheets("Feuil1").Find(resultat, LookIn:=xlValues, LookAt:=xlWhole)

End Sub

Je bloque sur la fonction .Find, ...

Pourriez-vous m'aider SVP ?

Merci d'avance pour vos réponses,

Cordialement,

Fabzo

Le 18/11/2013 à 12:09

bonjour,

voici un code adapté à tester

Sub Macro1()
'twb fait référence au classeur en cours
Set twb = ThisWorkbook
Dim resultat As String
    ' on demande le Lio"
    resultat = InputBox("Entrer numéro de LIO :", "Titre") 'La variable reçoit la valeur entrée dans l'InputBox

    If resultat <> "" Then 'Si la valeur est différente de "" on affiche le résultat
      MsgBox "Le LIO recherché est " & resultat
    End If
' on va parcourir un à un  toutes les feuilles du classeur en cours, ws identifie chacune de ces feuilles
For Each ws In twb.Worksheets
' on recherche le lio dans la feuille ws
Set trouve = ws.Cells.Find(resultat, LookIn:=xlValues, LookAt:=xlWhole)
' on a trouvé le lio
If Not trouve Is Nothing Then
' on ajoute un nouveau classeur
Set nwb = Workbooks.Add
' on copie la ligne où se trouve le Lio dans la première feuille du nouveau classeur
ws.Rows(trouve.Row).Copy nwb.Sheets(1).Range("A1")
' comme on a trouvé on arrête la recherche
Exit For
End If
' on passe au classeur suiavnt
Next
' un message si on n'a rien trouvé
If trouve Is Nothing Then
 MsgBox "LIO non trouvé"
End If
End Sub
Le 18/11/2013 à 13:22

Yes!

Merci beaucoup, ça m'a déjà bien avancé.

La recherche fonctionne et me recopie bien la ligne désirée dans un nouveau classeur.

Par contre, la macro s'arrete dés que la valeur est trouvée. Or, la valeur peut se trouver plusieurs fois dans un même onglet, et cela dans plusieurs onglets.

Voila les modifs apportées:

J'ai supprimé le Exit for de la boucle de recherche.

J'ai rajouté un compteur pour ne pas créer un nouveau classeur a chaque fois qu'une valeur recherchée est trouvée.

Comment ajouter une valeur dans le nouveau classeur?

Sub Macro1()
Dim i As Integer
i = 0
'twb fait référence au classeur en cours
Set twb = ThisWorkbook
Dim resultat As String
    ' on demande le Lio"
   resultat = InputBox("Entrer numéro de LIO :", "Titre") 'La variable reçoit la valeur entrée dans l'InputBox

    If resultat <> "" Then 'Si la valeur est différente de "" on affiche le résultat
     MsgBox "Le LIO recherché est " & resultat
    End If
' on va parcourir un à un  toutes les feuilles du classeur en cours, ws identifie chacune de ces feuilles
For Each ws In twb.Worksheets
i = i + 1  'i est un compteur qui permettra de creer le classeur une seule fois.
' on recherche le lio dans la feuille ws
Set trouve = ws.Cells.Find(resultat, LookIn:=xlValues, LookAt:=xlWhole)
' on a trouvé le lio
If Not trouve Is Nothing Then
' on ajoute un nouveau classeur
Set nwb = Workbooks.Add

If i = 1 Then   'la première fois on créé le classeur
' on copie la ligne où se trouve le Lio dans la première feuille du nouveau classeur
ws.Rows(trouve.Row).Copy nwb.Sheets(1).Range("A1")

If Not i = 1 Then   'la fois d'aprés on se contente de copier la ligne à la suite, donc sur la ligne numéro i
ws.Rows(trouve.Row).Copy nwb.Sheets(1).Range("Ai")

' comme on a trouvé on arrête la recherche
'Exit For
End If
' on passe au classeur suiavnt
Next
' un message si on n'a rien trouvé
If trouve Is Nothing Then
 MsgBox "LIO non trouvé"
End If

End Sub
Le 18/11/2013 à 13:40

bonjour,

code adapté pour prendre en compte toutes les occurrences trouvées, à tester

Sub Macro1()
'twb fait référence au classeur en cours
    Set twb = ThisWorkbook
    Dim resultat As String
    ' on demande le Lio"
    resultat = InputBox("Entrer numéro de LIO :", "Titre")    'La variable reçoit la valeur entrée dans l'InputBox

    If resultat <> "" Then    'Si la valeur est différente de "" on affiche le résultat
        MsgBox "Le LIO recherché est " & resultat
    End If
    ' on va parcourir un à un  toutes les feuilles du classeur en cours, ws identifie chacune de ces feuilles
            i = 0
    For Each ws In twb.Worksheets
        ' on recherche le lio dans la feuille ws
        Set trouve = ws.Cells.Find(resultat, LookIn:=xlValues, LookAt:=xlWhole)

        If Not trouve Is Nothing Then
            pAddresse = trouve.Address
            If i = 0 Then Set nwb = Workbooks.Add

            Do
                i = i + 1
                ws.Rows(trouve.Row).Copy nwb.Sheets(1).Range("A" & i)
                Set trouve = ws.Cells.FindNext(trouve)
            Loop While Not trouve Is Nothing And trouve.Address <> pAddresse
        End If

        ' on passe au classeur suivant
    Next
    If i = 0 Then
        MsgBox "lio non trouvé"
    End If
End Sub
Le 18/11/2013 à 15:52

Yes merci, marche impeccable.

Je cherche à présent à rajouter dans le fichier de destination, le nom de l'onglet d'ou provient la ligne qui a été copiée.

J'ai rajouté cette ligne :

nwb.Sheets(1).Cells("A", i).Value = ws.Name

Mais ca ne fonctionne pas.

Le code entier:

Sub Macro1()
'twb fait référence au classeur en cours
   Set twb = ThisWorkbook
    Dim resultat As String
    ' on demande le Lio"
   resultat = InputBox("Entrer numéro de LIO :", "Titre")    'La variable reçoit la valeur entrée dans l'InputBox

    If resultat <> "" Then    'Si la valeur est différente de "" on affiche le résultat
       MsgBox "Le LIO recherché est " & resultat
    End If
    ' on va parcourir un à un  toutes les feuilles du classeur en cours, ws identifie chacune de ces feuilles
           i = 0
    For Each ws In twb.Worksheets
        ' on recherche le lio dans la feuille ws
       Set trouve = ws.Cells.Find(resultat, LookIn:=xlValues, LookAt:=xlWhole)

        If Not trouve Is Nothing Then
            pAddresse = trouve.Address
            If i = 0 Then Set nwb = Workbooks.Add

            Do
                i = i + 1
                ws.Rows(trouve.Row).Copy nwb.Sheets(1).Range("B" & i)
                nwb.Sheets(1).Cells("A", i).Value = ws.Name               'pour copier le nom de l'onglet d'ou provient cette ligne
                Set trouve = ws.Cells.FindNext(trouve)
            Loop While Not trouve Is Nothing And trouve.Address <> pAddresse
        End If

        ' on passe au classeur suivant
   Next
    If i = 0 Then
        MsgBox "lio non trouvé"
    End If
End Sub
Le 18/11/2013 à 16:03

bonjour,

remplace

nwb.Sheets(1).Cells("A", i).Value = ws.Name

par

nwb.Sheets(1).Cells( i,"A").Value = ws.Name

ou encore

nwb.Sheets(1).range("A" & i).Value = ws.Name
Le 18/11/2013 à 16:06

L'erreur de débutant....

Merci beaucoup, ca fonctionne à merveille !!!

Le 08/05/2017 à 22:09

Bonjour,

J'ai utilisé beaucoup d'éléments de voter macro pour la mienne. Par contre, ma recherche se base sur une liste de représentant alors le début est un peu différent. ça fonctionne bien, à part que si un représentant X se retrouve dans plusieurs feuilles, la macro me créé un classeur supplémentaire. Alors que je voudrais plutôt que dans mon classeur créé, les infos trouvé dans la page suivante se colle sur une autre feuille.

Sub MacroOption1()

Set twb = ThisWorkbook

  Dim Lig     As Long
  Dim Col     As String
  Dim NbrLig  As Long
  Dim NumLig  As Long
  Dim resultat As String

  Col = "A"                 ' colonne de la donnée non vide à tester
  NumLig = 0
  With Sheets("Liste REP")     ' feuille source
  NbrLig = .Cells(65536, Col).End(xlUp).Row
  For Lig = 1 To NbrLig
  For Each ws In twb.Worksheets
  If ws.Name <> "Liste REP" Then
    resultat = .Cells(Lig, Col).Value
    If resultat <> "" Then
    i = 0
    Set trouve = ws.Cells.Find(resultat, LookIn:=xlValues, LookAt:=xlWhole)
    If Not trouve Is Nothing Then
    pAddresse = trouve.Address

    If i = 0 Then Set nwb = Workbooks.Add
                    Set nws = Worksheets.Add

    Do
    i = i + 1
    ws.Rows(trouve.Row).Copy nws.Range("A" & i + 1)
    nws.Name = ws.Name
    ws.Rows(1).Copy nws.Range("A" & 1)

    Set trouve = ws.Cells.FindNext(trouve)

    Loop While Not trouve Is Nothing And trouve.Address <> pAddresse

    End If

  End If
  End If
  Next
  Next
  End With

'
End Sub

Merci beaucoup

Rechercher des sujets similaires à "macro recherche valeur copie ligne"