Macro recherche puis copie de lignes

[zantinou]

Bonjour, J'ai besoin de votre aide...

J'ai une grande (très grande) liste extraite d'une base de données que j'ai besoin de traiter..
Il s'agit d'une liste extraite d'une GMAO qui répertorie quantités d'informations, interventions, pannes...
Comme cette liste est un peu mal foutue, je voudrais sélectionner puis copier toutes les lignes dont une seule cellule contient un mot précis, puis les extraire vers une autre feuille du même classeur.
Classeur dans lequel je pourrais procéder à un filtrage plus précis manuellement..

Bref je vois pas trop comment m'y prendre..
Si vous avez des idées, je frôle la tendinite du pouce à force de Ctrl+C, Crtl+V
Merci

 

[jetted]

Re : Macro recherche puis copie de lignes

Allo

Un peu difficile de t'aider car tu es un peu flou, et tu n'as pas attacher un exemple de ce que tu cherches a faire.

A prime abord je crois que je commencerais avec la fonction filtre ou filtre avancé. Une fois filtré (selon tes criteres) tu pourrais copier vers une autre feuille

Bonne chance

 

[skoobi]

Re : Macro recherche puis copie de lignes

Bonjour zantinou,

Si j'ai bien compris:

Sub test()
'##########################################################################"
'Ce code recherche sur toute la feuille 1 les cellules contenant "test"
'puis copie les lignes correspondantes vers la feuille 2
'##########################################################################"
Dim Trouve As Range, FirstAddress As String, MesLig As Range
  With Sheets(1).Cells
    Set Trouve = .Find("test", LookIn:=xlValues, lookat:=xlPart)
    If Not Trouve Is Nothing Then
      FirstAddress = Trouve.Address
      Do
        If MesLig Is Nothing Then
          Set MesLig = Rows(Trouve.Row)
        Else: Set MesLig = Union(Rows(Trouve.Row), MesLig)
        End If
        Set Trouve = .FindNext(Trouve)
      Loop While Trouve.Address <> FirstAddress
    End If
  End With
  MesLig.Copy Sheets(2).Range("a1")
End Sub

Edit: bonjour jetted

 

[PMO2]

Re : Macro recherche puis copie de lignes

Bonjour,

Une piste avec le code suivant à copier dans un module Standard

Sub LignesMotRecheche()
Dim S As Worksheet
Dim rep
Dim R As Range
Dim var
Dim dep&
Dim i&
Dim j&
Dim k&
Dim cpt&
Dim T()
Dim A$
Dim B$
rep = Application.InputBox("Tapez le mot à rechercher", "Lignes contenant le mot recherché")
If rep = False Or rep = "" Then Exit Sub
B$ = LCase(rep)
Set R = ActiveSheet.UsedRange
dep& = R.Row
var = R
For i& = 1 To UBound(var, 1)
  For j& = 1 To UBound(var, 2)
    A$ = LCase(Trim(var(i&, j&))) 'commodité d'écriture
    If InStr(1, A$, B$) > 0 Then
      cpt& = cpt& + 1
      ReDim Preserve T(1 To UBound(var, 2) + 1, 1 To cpt&)
      T(1, cpt&) = i& + dep& - 1
      For k& = 1 To UBound(var, 2)
        T(k& + 1, cpt&) = var(i&, k&)
      Next k&
      Exit For
    End If
  Next j&
Next i&
If cpt& = 0 Then
  MsgBox "Aucune occurence de ''" & rep & "'' n'a été trouvée."
  Exit Sub
Else
  Set S = Sheets.Add(before:=ActiveSheet)
  Set R = S.Range(S.Cells(1, 1), S.Cells(UBound(T, 2), UBound(T, 1)))
  R = Application.WorksheetFunction.Transpose(T)
End If
End Sub

Lancez la macro LignesMotRecheche puis renseignez l'InputBox du mot recherché.
Le résultat s'affiche dans une nouvelle feuille à partir de la colonne B.
J'ai réservé la colonne A pour inscrire les numéros de lignes.

Cordialement.

PMO
Patrick Morange

 

[zantinou]

Re : Macro recherche puis copie de lignes

Excellent !!!
Ça fonctionne parfaitement comme je le voulais..et dslé, je ne voyais pas trop comment expliquer plus simplement..

merci encore

 

[Corkalex]

Re : Macro recherche puis copie de lignes

Bonjour tout le monde

Je suis tomber sur cette macro qui me va bien mais j'aurais aimé savoir si il était possible de l'étendre sur un classeur et si possible de pouvoir recherché plusieurs mots clés.
(je sais j'en demande beaucoup ^^ et en plus je connait pas grand chose à excel)


Je developpe : j'ai un classeur avec 15 feuilles, les feuilles sont construite de la meme maniere:
colonne A : la gamme de produits
colonne b : référence
colonne c : descriptif produit
colonne d : le prix

Chaque feuille est propre à un constructeur.
Le résultat souhaité serai que suite à la recherche, toutes les lignes comprenant le mot clé soit copié sur une autre feuille.

Je vous remercie d'avance

 

[PMO2]

Re : Macro recherche puis copie de lignes

Bonjour,

Voici une évolution du programme qui prend en compte
1) la recherche sur toutes les feuilles du classeur
2) la possibilité de rechercher plusieurs mots clés. Pour cela, les séparer par un BackSlash ( \ )

Copier le code suivant dans un module standard

Sub LignesMultiMotsClasseur()
Dim WB As Workbook
Dim S As Worksheet
Dim rep
Dim R As Range
Dim Titres
Dim var
Dim dep&
Dim g&
Dim h&
Dim i&
Dim j&
Dim k&
Dim cpt&
Dim T()
Dim A$
Dim B$()
On Error GoTo Erreur
Titres = Array("Mot recherché", "Feuille", "N° de ligne")
rep = Application.InputBox( _
    "Tapez le mot à rechercher" & vbCrLf & vbCrLf & _
    "Si plusieurs mots, les séparer par un antislash ( \ )", _
    "Lignes contenant les mots recherchés")
If rep = False Or rep = "" Then Exit Sub
A$ = LCase(rep)
Do Until Left(A$, 1) <> "\" And Left(A$, 1) <> Space(1)
  A$ = Mid(A$, 2)
Loop
Do Until Right(A$, 1) <> "\" And Right(A$, 1) <> Space(1)
  A$ = Mid(A$, 1, Len(A$) - 1)
Loop
If InStr(1, A$, "\") = 0 Then
  ReDim B$(1 To 1)
  B$(1) = A$
Else
  Do Until A$ = ""
    If Right(A$, 1) <> "\" Then A$ = A$ & "\"
    i& = i& + 1
    ReDim Preserve B$(1 To i&)
    B$(i&) = Mid(A$, 1, InStr(1, A$, "\") - 1)
    A$ = Trim(Mid(A$, Len(B$(i&)) + 2))
    Do Until Left(A$, 1) <> "\" And Left(A$, 1) <> Space(1)
      A$ = Mid(A$, 2)
    Loop
    B$(i&) = Trim(B$(i&))
  Loop
End If
Set WB = ActiveWorkbook
For h& = 1 To WB.Worksheets.Count
  Set S = WB.Worksheets(h&)
  Set R = S.UsedRange
  dep& = R.Row
  var = R
  If R.Columns.Count > 253 Then
    MsgBox "La feuille ''" & S.Name & _
        "'' ne peut être traitée car elle comporte plus de 253 colonnes."
  Else
    If Not IsEmpty(var) Then
      For g& = 1 To UBound(B$)
        For i& = 1 To UBound(var, 1)
          For j& = 1 To UBound(var, 2)
            A$ = LCase(Trim(var(i&, j&)))
            If InStr(1, A$, B$(g&)) > 0 Then
              cpt& = cpt& + 1
              ReDim Preserve T(1 To 253, 1 To cpt&)
              T(1, cpt&) = B$(g&)
              T(2, cpt&) = S.Name
              T(3, cpt&) = i& + dep& - 1
              For k& = 1 To UBound(var, 2)
                T(k& + 3, cpt&) = var(i&, k&)
              Next k&
              Exit For
            End If
          Next j&
        Next i&
      Next g&
    End If
  End If
Next h&
If cpt& = 0 Then
  A$ = ""
  For i& = 1 To UBound(B$)
    A$ = A$ & vbCrLf & B$(i&)
  Next i&
  MsgBox "Aucune occurence de" & A$ & vbCrLf & "n'a été trouvée."
  Exit Sub
Else
  Application.ScreenUpdating = False
  Set S = Sheets.Add(before:=ActiveSheet)
  Set R = S.Range(S.Cells(2, 1), S.Cells(UBound(T, 2) + 1, UBound(T, 1)))
  R = Application.WorksheetFunction.Transpose(T)
  Set R = S.Range(S.Cells(1, 1), S.Cells(1, UBound(Titres) + 1))
  R = Titres
  R.HorizontalAlignment = xlCenter
  R.Font.Bold = True
  R.Interior.ColorIndex = 40
  S.Cells.Columns.AutoFit
End If
Erreur:
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox "Erreur : " & Err.Number & vbCrLf & Err.Description
End Sub

Lancez la macro LignesMultiMotsClasseur puis renseignez l'InputBox du ou des mots recherchés.
Le résultat s'affiche dans une nouvelle feuille à partir de la colonne D.
J'ai réservé les colonnes
"A" pour inscrire les mots clés recherchés
"B" pour inscrire le nom de la feuille
"C" pour inscrire le numéro de la ligne trouvée

Cordialement.

PMO
Patrick Morange

 

[Corkalex]

Re : Macro recherche puis copie de lignes

Bonjour,

Tout d'abord merci beaucoup PMO2 pour le temps accordé !!

Passons maintenant aux choses sérieuse:

la recherche fonctionne très bien pour une recherche avec un mots cependant des que je veut mettre plusieurs critères (séparé par "\" ) j'ai le message d'erreur suivant : " Erreur 13 : incompatibilité de type"
Je suis un peu perdue......

Je sais que k'on va me demander de mettre mon fichier excel en ligne mais je ne peut malheuresement pas.

Si quelqu'un a une idée il est le bienvenue