Rechercher une partie de texte dans une cellule et copier la lig
Résolu
Dom.are
Messages postés
15
Date d'inscription
Statut
Membre
Dernière intervention
-
Dom.are Messages postés 15 Date d'inscription Statut Membre Dernière intervention -
Dom.are Messages postés 15 Date d'inscription Statut Membre Dernière intervention -
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
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
A voir également:
- Rechercher une partie de texte dans une cellule et copier la lig
- Excel cellule couleur si condition texte - Guide
- Comment copier une vidéo youtube - Guide
- Aller à la ligne dans une cellule excel - Guide
- Rechercher ou saisir une url - Guide
- Comment faire une recherche à partir d'une photo - Guide
2 réponses
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
