rechercher une partie de texte dans une cellule et copier la lig Résolu/Fermé

Question

Bonjour, 

Je viens vers vous car je bloque sur la recherche d'une partie de texte dans une cellule et si elle est présente copier la ligne complète dans une autre feuille.
quand j'utilise ce code : je recopie toutes les lignes du fichier entrée

Dim Lig     As Long
  Dim Col     As String
  Dim NbrLig  As Long
  Dim NumLig  As Long
    
  Sheets("Feuil1").Activate ' feuille de destination
   Col = "Q"                 ' colonne à tester
  NumLig = 3
  With Sheets("fichier entrée")     ' feuille source
  NbrLig = .Cells(65536, Col).End(xlUp).Row
  For Lig = 1 To NbrLig
       If Cells.Find(What:="*Blackout_custom*", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Select Then
     
      .Cells(Lig, Col).EntireRow.Copy
      NumLig = NumLig + 1
      Cells(NumLig, 1).Select
      ActiveSheet.Paste

"blackout_custom" est contenu dans une cellule comme celle-ci :

19 févr, 04h17     Suspension   L''alerte a été snoozée du 19 févr, 04:17 au 19 févr, 05:17 (Snoozer par Automate. Processus d''alerte Nagios CPU < 60mns.).  19 févr, 04h17     Snoozé   L''alerte a été snoozée à partir du 19 févr, 04:17 (Blackout [ON] : rBA14 - Blackout CPULISSE  NUIT [ Calendar : Blackout_Custom_20h_6h ] ).  19 févr, 04h17     Snoozé   L''alerte a été snoozée à partir du 19 févr, 04:17 (Blackout [ON] : rBA14 - Blackout CPULISSE  NUIT [ Calendar : Blackout_Custom_20h_6h ] ).  19 févr, 06h00     Ouverture   L''alerte a été re-ouverte après avoir été snoozée Blackout [OFF] : rBA14 - Blackout CPULISSE  NUIT.  19 févr, 06h00     Ouverture   L''alerte a été re-ouverte après avoir été snoozée  (Blackout [OFF] : rBA14 - Blackout CPULISSE  NUIT).  19 févr, 06h07     Urgence   Changement de l''Urgence de .....

Merci d'avance si quelqu'un peut m'aider.
A bientôt j'espère

f894009 · Answer

Bonjour,

Sub test()
    Dim Lig As Long
    Dim Col As String
    Dim NbrLig As Long
    Dim NumLig As Long
    Dim Plage As Range

Sheets("Feuil1").Activate ' feuille de destination
    Col = "Q" ' colonne à tester
    NumLig = 3
    With Sheets("fichier entrée") ' feuille source
        NbrLig = .Cells(65536, Col).End(xlUp).Row
        Set Plage = .Range("Q1:Q" & NbrLig)
        Nb = Application.CountIf(Plage, "*Blackout_custom*")
        If Nb > 0 Then
            Lig = 1
            For Iter = 1 To Nb
                Lig = .Columns("Q").Find("*Blackout_custom*", .Cells(Lig, "Q"), , xlWhole).Row
                NumLig = NumLig + 1
                .Cells(Lig, Col).EntireRow.Copy Sheets("Feuil1").Cells(NumLig, 1)
            Next Iter
        Else
            MsgBox "Desole, n'existe pas !!!!!!"
        End If
    End With
End Sub

Dom.are · Answer

Bonjour,

Un grand merci à vous en regardant c'est certain soit je n'y serai pas arrivé ou alors peut être après mon départ à la retraite (dans 4 ans !!!!!!!)

Encore merci ça marche super bien et aussi pour votre rapidité .

Rechercher une partie de texte dans une cellule et copier la lig

2 réponses

Discussions similaires

Newsletters