Garder uniquement les lignes avec texte de couleur rouge

[IZELLOUP]

🙂 Bonjour le forum.

Je recherche une solution par macro de préférence afin de conserver uniquement les lignes de ma feuille dont le texte est en rouge. La feuille d'origine possède plus de 6000 lignes.
Merci beaucoup.
Izelloup.😱

 

[DoubleZero]

Re : Garder uniquement les lignes avec texte de couleur rouge

Bonjour, IZELLOUP, le Forum,

Une suggestion :

Sub Lignes_non_rouges_supprimer()
Application.ScreenUpdating = False
Dim i As Long
    For i = Range("a65536").End(xlUp).Row To 2 Step -1
        If Range("a" & i).Font.ColorIndex <> 3 Then Rows(i).Delete
    Next
Application.ScreenUpdating = True
End Sub

A bientôt 🙂

 

[Victor21]

Re : Garder uniquement les lignes avec texte de couleur rouge

Bonsoir, IZELLOUP

Question préalable : pourquoi certaines lignes sont-elles rouges ?
En complément :
- Y a-t'il un critère logique
- Si oui, lequel ?
- Sinon qui met ces lignes en rouge ?
- Si c'est vous, pouvez-vous, en alternative, mettre une annotation en colonne I ?

Edit : Bonsoir, OO 😉

 

[IZELLOUP]

Re : Garder uniquement les lignes avec texte de couleur rouge

Bonsoir DoubleZero,

Cela marche bien,Merci. Cependant, y a t-il moyen d'améliorer le code afin que l'opération soit plus rapide ?
Cordialement.

 

[IZELLOUP]

Re : Garder uniquement les lignes avec texte de couleur rouge

Bonsoir Patrick,

Désolé, je testais la solution de Doublezéro. Pour être plus précis. Ces lignes sont obtenues par extraction grâce à une requête html.
Cordialement.
Stéphane.

 

[DoubleZero]

Re : Garder uniquement les lignes avec texte de couleur rouge

Re-bonjour, bonjour, Victor21 😀,

Tester ceci :

Sub Lignes_non_rouges_supprimer()
Dim i As Long
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
        For i = Range("a65536").End(xlUp).Row To 2 Step -1
            If Range("a" & i).Font.ColorIndex <> 3 Then Rows(i).Delete
        Next
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

A bientôt 🙂

 

[IZELLOUP]

Re : Garder uniquement les lignes avec texte de couleur rouge

Re,

Merci encore, c'est légèrement plus rapide sans plus.
cldt

 

[DoubleZero]

Re : Garder uniquement les lignes avec texte de couleur rouge

Re-bonjour,

... c'est légèrement plus rapide sans plus...

La méthode "Scripting.Dictionary" pourrait, sans doute, être adoptée.

Hélas... mon petit neurone ne parvient pas à la maîtriser 🙁

A bientôt 🙂

 

[job75]

Re : Garder uniquement les lignes avec texte de couleur rouge

Bonsoir tout le monde,

Ceci est forcément plus rapide car la suppression se fait en bloc :

Sub Lignes_non_rouges_supprimer()
Dim cel As Range, sup As Range
Application.ScreenUpdating = False 'peut-être inutile
For Each cel In Range("A2", [A65536].End(xlUp)) 'A2 si titres en ligne 1
  If cel.Font.ColorIndex <> 3 Then Set sup = Union(IIf(sup Is Nothing, cel, sup), cel)
Next
If Not sup Is Nothing Then sup.EntireRow.Delete
End Sub

A+

 

[IZELLOUP]

Re : Garder uniquement les lignes avec texte de couleur rouge

Bonsoir Job75,

Effectivement, c'est beaucoup plus rapide (environ 4mn pour mes 6000 lignes). Cela me convient parfaitement. Grand merci à toi et à DoubleZero pour vos propositions.
Bonne soirée.
Cordialement.
Stéphane.

 

[Jacou]

Re : Garder uniquement les lignes avec texte de couleur rouge

Bonsoir à tous,

sans VBA, il y a aussi le filtre par couleur :
on met en place un filtre,
on sélectionne une couleur qui n'est pas rouge,
puis on sélectionne toutes les lignes filtrées et on appuie sur sup.

s'il n'y a pas 36 couleurs différentes c'est assez rapide!

 

[BOISGONTIER]

Re : Garder uniquement les lignes avec texte de couleur rouge

Bonjour,

Voir PJ

Cette méthode est la plus rapide(les lignes à supprimer sont regroupées à la fin).

0,1 s pour 10.000 lignes

Sub supLignesRapide()
  Application.ScreenUpdating = False
  a = Range("A1:A" & [A65000].End(xlUp).Row)
  For i = LBound(a) To UBound(a)
    If Cells(i, 1).Font.ColorIndex = 3 Then a(i, 1) = 0 Else a(i, 1) = "sup"
  Next i
  Columns("b:b").Insert Shift:=xlToRight
  [B1].Resize(UBound(a)) = a
  [A2].CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess
  On Error Resume Next
  Range("B2:B65000").SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
  Columns("b:b").Delete Shift:=xlToLeft
End Sub

JB

 

[job75]

Re : Garder uniquement les lignes avec texte de couleur rouge

Bonjour JB, le forum,

Placer les lignes à supprimer en bas du tableau est en effet essentiel, merci de l'avoir rappelé.

Nota : j'ai recopié le tableau sur 10000 lignes, sur portable avec Windows 7 et Excel 2010 => 3,7 secondes.

A+

 

[IZELLOUP]

Re : Garder uniquement les lignes avec texte de couleur rouge

Bonjour BOISGONTIER, le forum,

Bravo, encore plus rapide ! Moins d'une minute chez moi avec une configuration PC basée sur un Core2 duo E6750. Cela me convient largement. Merci à tous.
A bientôt.
Stéphane.