VBA, rechercher et supprimer des lignes

Bonjour,

Dans mon fichier je cherche à mettre en évidence toutes les lignes comprenant un certains mot, et ensuite supprimer les autres. Je suis novice dans tous ça et donc j'essaie de me débrouiller.

Grâce à un autres sujet de ce forum, j'ai copier et modifié ce code qui me mets en rouge toutes les lignes avec écrit "rivat" dedans. Cependant est-il possible de mettre une cellule à la place du nom (pour que je puisse changer le critère de recherche facilement). J'ai essayé de mettre simplement le numéro de cellule à la place du nom, mais ça ne marche pas.

J'ai rajouté le 2ème if, et je veux qu'il fasse l'inverse ce qu'il me fait : là il supprime toutes les lignes en rouge. Je n'arrive pas à trouver, si je rajoute un not, ça fait rien.

Et pour finir, je voudrais ajouter un code qui m'annule tout et me remet toutes mes données pour retrouver mon fichier original.

Sub ModifTexte()

Dim Cel As Range

Dim Depart As String

Set Cel = Columns(1).Find(what:="rivat", LookIn:=xlValues, lookat:=xlPart)

If Not Cel Is Nothing Then

Depart = Cel.Address

Do

Rows(Cel.Row).Font.ColorIndex = 3

Set Cel = Columns(1).FindNext(Cel)

Loop While Not Cel Is Nothing And Cel.Address <> Depart

End If

If Rows(Cel.Row).Font.ColorIndex = 3 Then

Rows(Cel.Row).Delete

End If

End Sub

Un grand merci à ceux qui prendront le temps de m'aider.

Cependant est-il possible de mettre une cellule à la place du nom

transforme cette partie du code:

Set Cel = Columns(1).Find(what:="rivat", LookIn:=xlValues, lookat:=xlPart)

par

Set Cel = Columns(1).Find(what:=Range("A1"), LookIn:=xlValues, lookat:=xlPart)

Rows(Cel.Row).Font.ColorIndex = 3

a modifier pour qu'il prenne tout sauf le colorindex a 3?

Rows(Cel.Row).Font.ColorIndex <>3

je voudrais ajouter un code qui m'annule tout et me remet toutes mes données pour retrouver mon fichier original.

il serais plus simple de copier ce qui t'interresse sur une nouvelle feuille, non?

Pour la cellule cela marche, j'avais oublié le "range" ...

Pour le reste, toute cette manipulation a en effet pour but final de copier toutes ces lignes sur une nouvelle feuille. Mais étant débutante, je fais avec ce que je comprends lol ! Voire même un couper coller dans une autre feuille ça serait mieux !

(si je devais bien changer le = en <> dans le 2ème if, cela n'a pas marché)

Merci ! Merci ! Merci ! et encore MERCI !

but final de copier toutes ces lignes sur une nouvelle feuille.

If Rows(Cel.Row).Font.ColorIndex = 3 Then
Rows(Cel.Row).copy sheets("feuil2").range("a1")
End If

La il est censé copier toutes les lignes rouges sur la feuil2

Il ne me copie qu'une seule ligne.

Et est-il possible de mettre nouvelle feuille plutôt que feuille 2 car j'ai une petite dizaine de nom à faire sortir.

Merci

On Error Resume Next 'On s'affranchit de toute les erreurs dans le code
  Sheets("Semaine").Visible = True 'Mettre sa propriété Visible à True
  '(offre une valeur d'erreur:0 si la feuille existe)
  Faute = Err.Number 'recupere le n° d'erreur
  On Error GoTo 0 'réinitialise les erreurs
  If Faute > 0 Then 'si..alors*
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Semaine" ' a remplacer par ce que tu veux (meme range("A1").value par exemple)
    Else 'sinon...*
    MsgBox "Feuille existante"
    Exit Sub
  End If '...fin d'if*

Pour créer une feuille nouvelle appellé "semaine"...

lignesuiv = Cells(Rows.Count, 1).End(xlUp).Row + 1 'ligne vide suivante
for i =1 to "ton nombre de ligne"
    If Rows(Cel.Row).Font.ColorIndex = 3 Then
    Rows(Cel.Row).copy sheets("feuil2").range("A" & lignesuiv)
    End If
next i

essaye ca

oula ça devient compliqué ...

Que veux tu que je copie, et à quel niveau du code ?

Sub ModifTexte()
Dim Cel As Range
Dim Depart As String
'**Colorie les lignes**
Set Cel = Columns(1).Find(what:=Range("A1"), LookIn:=xlValues, lookat:=xlPart)
If Not Cel Is Nothing Then
Depart = Cel.Address
Do
Rows(Cel.Row).Font.ColorIndex = 3
Set Cel = Columns(1).FindNext(Cel)
Loop While Not Cel Is Nothing And Cel.Address <> Depart

End If

'**creer la nouvelle feuille**
On Error Resume Next 'On s'affranchit de toute les erreurs dans le code
 Sheets("Semaine").Visible = True 'Mettre sa propriété Visible à True
 '(offre une valeur d'erreur:0 si la feuille existe)
 Faute = Err.Number 'recupere le n° d'erreur
 On Error GoTo 0 'réinitialise les erreurs
 If Faute > 0 Then 'si..alors*
   Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Semaine" ' a remplacer par ce que tu veux (meme range("A1").value par exemple)
   Else 'sinon...*
   MsgBox "Feuille existante"
    Exit Sub
  End If '...fin d'if*

'**transfere les lignes rouges vers la Semaine**
sheets("feuille d'arrivé").activate
lignesuiv = Cells(Rows.Count, 1).End(xlUp).Row + 1 'ligne vide suivante
sheets("feuille source").activate
for i =1 to "ton nombre de ligne"
    If Rows(i).Font.ColorIndex = 3 Then
    Rows(i).copy sheets("Semaine").range("A" & lignesuiv)
    End If
next i

ton code devrais avoir cette tete la a peu pres.

J'ai repris ton code et ce que j'ai souligné c'est ce que j'ai adapté, et ce qui est en gras c'est ce que où je me demande si il faut l'adapter aussi.

Suis-je à coté de la plaque ou pas loin ?

En tous cas, mille merci !

Sub ModifTexte()

Dim Cel As Range

Dim Depart As String

'**Colorie les lignes**

Set Cel = Columns(1).Find(what:=Range("A1"), LookIn:=xlValues, lookat:=xlPart)

If Not Cel Is Nothing Then

Depart = Cel.Address

Do

Rows(Cel.Row).Font.ColorIndex = 3

Set Cel = Columns(1).FindNext(Cel)

Loop While Not Cel Is Nothing And Cel.Address <> Depart

End If

'**creer la nouvelle feuille**

On Error Resume Next 'On s'affranchit de toute les erreurs dans le code

Sheets("Semaine").Visible = True 'Mettre sa propriété Visible à True

'(offre une valeur d'erreur:0 si la feuille existe)

Faute = Err.Number 'recupere le n° d'erreur

On Error GoTo 0 'réinitialise les erreurs

If Faute > 0 Then 'si..alors*

Sheets.Add After:=Sheets(Sheets.Count)

ActiveSheet.Name = Range("A1").Value ' a remplacer par ce que tu veux (meme range("A1").value par exemple)

Else 'sinon...*

MsgBox "Feuille existante"

Exit Sub

End If '...fin d'if*

'**transfere les lignes rouges vers la Semaine**

Sheets("feuille d'arrivé").Activate

lignesuiv = Cells(Rows.Count, 1).End(xlUp).Row + 1 'ligne vide suivante

Sheets("feuille source").Activate

For i = 1 To 529

If Rows(Cel.Row).Font.ColorIndex = 3 Then

Rows(Cel.Row).Copy Sheets(Range("A1").Value).Range("A" & lignesuiv)

End If

Next i

en gras est a adapter aussi, je ne connais pas les noms de tes feuilles

feuille d'arrivé= sheets(Range("A1").Value)

feuille source= la feuille base de données

ca ne marche pas, je desepère ...

Sub ModifTexte()

Dim Cel As Range

Dim Depart As String

'**Colorie les lignes**

Set Cel = Columns(1).Find(what:=Range("A1"), LookIn:=xlValues, lookat:=xlPart)

If Not Cel Is Nothing Then

Depart = Cel.Address

Do

Rows(Cel.Row).Font.ColorIndex = 3

Set Cel = Columns(1).FindNext(Cel)

Loop While Not Cel Is Nothing And Cel.Address <> Depart

End If

'**creer la nouvelle feuille**

On Error Resume Next 'On s'affranchit de toute les erreurs dans le code

Sheets("Semaine").Visible = True 'Mettre sa propriété Visible à True

'(offre une valeur d'erreur:0 si la feuille existe)

Faute = Err.Number 'recupere le n° d'erreur

On Error GoTo 0 'réinitialise les erreurs

If Faute > 0 Then 'si..alors*

Sheets.Add After:=Sheets(Sheets.Count)

ActiveSheet.Name = Range("A1").Value ' a remplacer par ce que tu veux (meme range("A1").value par exemple)

Else 'sinon...*

MsgBox "Feuille existante"

Exit Sub

End If '...fin d'if*

'**transfere les lignes rouges vers la Semaine**

Sheets(Range("A1").Value).Activate

lignesuiv = Cells(Rows.Count, 1).End(xlUp).Row + 1 'ligne vide suivante

Sheets("feuil1").Activate

For i = 1 To 529

If Rows(Cel.Row).Font.ColorIndex = 3 Then

Rows(Cel.Row).Copy Sheets(Range("A1").Value).Range("A" & lignesuiv)

End If

Next i

End Sub

Sheets("Semaine").Visible = True

faut modifier cette ligne aussi

Si tu as un morceau du fichier a envoyer, ca sera peut etre plus simple

En effet, j'oublie toujours l'envoi du fichier ...

voila, je debute aussi donc quelques erreurs sont apparu.

apparement il n'aime pas le nom de feuille "range("a1").value", je l'ai remplacé par "semaine"(a toi de lui donné le nom que tu veux.).


ca y est j'ai trouvé...

J'ai réussi à résoudre le pb de nom de feuille, mais quand je change le nom dans A1, au lieu de me mettre seulement ce nom, ça l'ajoute au 2 autres.

Normal, on fait la recherche sur les ligne rouges...or on ne les remets pas en noir a la fin de la recherche.

il compile ttes les recherches du coup.

erreur modifié

na c'est bon ça marche !!! j'avais oublié d'enlever les rouge !!!

merci merci merci merci merci !

Je ne pourrais pas le dire assez de fois je pense !

Rechercher des sujets similaires à "vba rechercher supprimer lignes"