Recherche multiples et extraction

[seb2]

Bonjour à tous,

Je cherche à faire une macro me permettant rechercher et surligner en couleur tous les mots ou tous les chiffres contenu dans le listing du classeur, et lorsque le mot ou les chiffres sont trouvés copier les lignes entière dans l'onglet feuil2 d' excel (Le tableau comporte plusieurs millier de lignes et nombreuses colonnes) plusieurs mots ou lettre peuvent être defini par l'utilisateur (en ligne N°1 par exemple) (voir le fichier joint)
Quelqu'un peut-il m'aider parce que je ne connais pas biens les macros

Merci🙂

 

[BOISGONTIER]

Re : Recherche multiples et extraction

Bonsoir,

Sub essai()
  Set rng1 = Range("A2", [IV2].End(xlToLeft))
  Set rng2 = Range("A6:F10000")
  ligne = 2
  Sheets("feuil1").Select
  Sheets("feuil2").Cells.Clear
  rng2.ClearFormats
  For Each x In rng1
    Set c = rng2.Find(what:=x, LookIn:=xlValues)
    If Not c Is Nothing Then
      premier = c.Address
      Do
        If Cells(c.Row, 1).Interior.ColorIndex <> 4 Then
          Rows(c.Row).Copy Sheets("feuil2").Cells(ligne, 1)
          ligne = ligne + 1
        End If
        Rows(c.Row).Interior.ColorIndex = 4
        Set c = rng2.FindNext(c)
      Loop While Not c Is Nothing And c.Address <> premier
    End If
  Next x
End Sub

JB

 

[seb2]

Re : Recherche multiples et extraction

Bonjour BOISGONTIER,

Merci beaucoup, ton programme marche super bien !!!
Pourrais-tu m'expliquer un peu le programme histoire de progresser en macro car je débute.
Si par exemple je veux surligner que le mot reconnu comment dois faire.

A+ seb2

 

[BOISGONTIER]

Re : Recherche multiples et extraction

Bonjour,

Sub essai()
  Set rng1 = Range("A2", [IV2].End(xlToLeft))
  Set rng2 = Range("A6:F10000")
  ligne = 2
  Sheets("feuil1").Select
  Sheets("feuil2").Cells.Clear
  rng2.ClearFormats
  For Each x In rng1     ' pour chaque cellule de rng1
    Set c = rng2.Find(what:=x, LookIn:=xlValues)   ' trouver le premier dans rng2
    If Not c Is Nothing Then
      premier = c.Address
      Do                                           ' boucle tous
        If Cells(c.Row, 1).Font.ColorIndex <> 3 Then
          Rows(c.Row).Copy Sheets("feuil2").Cells(ligne, 1)
          ligne = ligne + 1
        End If
        c.Interior.ColorIndex = 4
        Cells(c.Row, 1).Font.ColorIndex = 3        ' témoin déjà transféré
        Set c = rng2.FindNext(c)
      Loop While Not c Is Nothing And c.Address <> premier
    End If
  Next x
End Sub

JB

 

[seb2]

Re : Recherche multiples et extraction

Re bonjour,


Merci beaucoup, ta macro marche très bien

A+seb🙂