Filtre selon couleur

Vilain

XLDnaute Accro
Bonjour à tous,

J'ai un fichier comportant un certain nombre de lignes et de colonnes au sein duquel certaines informations sont écrites en rouge.
Je cherche à filtrer uniquement les lignes comportant au moins une informations en rouge.

Comment faire ?

Je joins un fichier pour ex.

Merci d'avance.

A plus
 

Pièces jointes

  • filtre selon couleur.xls
    28.5 KB · Affichages: 75

Vilain

XLDnaute Accro
Re : Filtre selon couleur

Salut Victor,

Non, elle est aléatoire.
Pour être complet, iol s'agit des informations qui ont été changées par quelqu'un d'autre.
C'est le seul moyen pour moi de savoir ce qui a été modifié.
Et sachant que le fichier fait parfois plusieurs centaines de lignes par environ 50 colonnes...

Merci d'avance.
 

job75

XLDnaute Barbatruc
Re : Filtre selon couleur

Bonjour Gillus69, Patrick,

Ceci paraît assez simple :

Code:
Sub FiltrerRouge()
Dim plage As Range, cel As Range, filtre As Range
Application.ScreenUpdating = False
Set plage = Intersect(ActiveSheet.UsedRange, Rows("2:65536"))
If plage Is Nothing Then Exit Sub 'sécurité
For Each cel In plage
  If cel.Font.ColorIndex = 3 Then _
    Set filtre = Union(IIf(filtre Is Nothing, cel, filtre), cel)
Next
plage.EntireRow.Hidden = True
If Not filtre Is Nothing Then filtre.EntireRow.Hidden = False
End Sub

Sub AfficheTout()
Rows.Hidden = False
End Sub
Fichier joint.

A+
 

Pièces jointes

  • filtre selon couleur(1).xls
    57 KB · Affichages: 92

Vilain

XLDnaute Accro
Re : Filtre selon couleur

Bonjour job,

Merci pour ta solution qui parait effectivement assez simple.
C'est la ligne copiée en dessous qui te permet de gérer le fait que ce peut-être dans n'importe quelle colonne, non ?
Set plage = Intersect(ActiveSheet.UsedRange, Rows("2:65536"))
Comment cela fonctionne-t-il ?

Encore merci pour cette brillante solution.

A plus
 

job75

XLDnaute Barbatruc
Re : Filtre selon couleur

Re,

Oui, la macro étudie toutes les cellules situées dans Intersect(ActiveSheet.UsedRange, Rows("2:65536"))

Il s'agit donc du UsedRange (voir l'aide VBA) sauf la ligne 1.

Nota : des cellules peuvent être vides mais avec une police rouge.

Si l'on veut ne pas les prendre en compte, utiliser comme test dans la macro :

If cel <> "" And cel.Font.ColorIndex = 3 Then...

A+
 

TEMAGOULTFARID

XLDnaute Occasionnel
Re : Filtre selon couleur

Bonjour Gillus69, Patrick,

Ceci paraît assez simple :

Code:
Sub FiltrerRouge()
Dim plage As Range, cel As Range, filtre As Range
Application.ScreenUpdating = False
Set plage = Intersect(ActiveSheet.UsedRange, Rows("2:65536"))
If plage Is Nothing Then Exit Sub 'sécurité
For Each cel In plage
  If cel.Font.ColorIndex = 3 Then _
    Set filtre = Union(IIf(filtre Is Nothing, cel, filtre), cel)
Next
plage.EntireRow.Hidden = True
If Not filtre Is Nothing Then filtre.EntireRow.Hidden = False
End Sub

Sub AfficheTout()
Rows.Hidden = False
End Sub
Fichier joint.

A+
Bonjour
merci a vous , je prends , c'est ce que je voulais.
bonne journée
 

TEMAGOULTFARID

XLDnaute Occasionnel
Re : Filtre selon couleur

Re,

D'ailleurs un seul bouton et une seule macro (paramétrée) suffisent.

Fichier (2).

A+
Bonjour Job75, j'ai vu ton fichier qui fonctionne tres bien, cepandant est-il possible pour plusiers couleurs et d choisir les cellules a filtre comme dans mon cas a partir de N6 et Y infini.Je te remet ton fichier en PJ .Par avance merci et bonne journée
 

Pièces jointes

  • filtre selon couleur(1) (2).xls
    57 KB · Affichages: 5

TEMAGOULTFARID

XLDnaute Occasionnel
Bonjour Job75, j'ai vu ton fichier qui fonctionne tres bien, cepandant est-il possible pour plusiers couleurs et d choisir les cellules a filtre comme dans mon cas a partir de N6 et Y infini.Je te remet ton fichier en PJ .Par avance merci et bonne journée
hello, j’oubliais aussi , est-il possible de mettre plutot les code couleur style RVB 0.255.0 que les N° 4........Merci
 

job75

XLDnaute Barbatruc
Bonjour TEMAGOULTFARID, le forum,

La solution que j'ai donnée en 2012 ne va pas très bien.

Sur le fichier (2) du post #7 copiez la plage A2:C11 sur A12:C10001 et cliquez sur le bouton.

Chez moi la macro s'exécute en 125 secondes, c'est rédhibitoire.

En effet la fonction Union pédale dans la choucroute quand il y a beaucoup de plages disjointes.

De plus la macro ne traite pas le cas où une partie du texte est coloré.

Avec ce fichier (3) et cette macro il n'y a plus de problème :
VB:
Sub FiltrerRouge(filtre As Boolean)
If filtre Then
    Dim decharge%, plage As Range, cel As Range, fci As Variant, i%, f As Range, n%
    decharge = 100
    Set plage = Intersect(ActiveSheet.UsedRange, Rows("2:" & Rows.Count))
    If plage Is Nothing Then Exit Sub 'sécurité
    Application.ScreenUpdating = False
    plage.EntireRow.Hidden = True
    For Each cel In plage
        If cel <> "" Then
            fci = cel.Font.ColorIndex
            If IsNull(fci) Then 'si coloration partielle
                For i = 1 To Len(cel)
                    If cel.Characters(i, 1).Font.ColorIndex = 3 Then GoTo 1
                Next i
            ElseIf fci = 3 Then
1               Set f = Union(IIf(n, f, cel), cel)
                n = n + 1
            End If
            If n = decharge Then f.EntireRow.Hidden = False: n = 0: Set f = Nothing
        End If
    Next cel
    If n Then f.EntireRow.Hidden = False
Else
    Rows.Hidden = False
End If
End Sub
A+
 

Pièces jointes

  • filtre selon couleur(3).xls
    51 KB · Affichages: 7

job75

XLDnaute Barbatruc
S'il y a plusieurs couleurs à filtrer ensemble on peut utiliser le Dictionary, voyez ce fichier (4) :
VB:
Sub FiltrerCouleurs(filtre As Boolean)
If filtre Then
    Dim decharge%, plage As Range, d As Object, cel As Range, fci As Variant, i%, f As Range, n%
    decharge = 100
    Set plage = Intersect(ActiveSheet.UsedRange, Range("A2:C" & Rows.Count)) 'colonnes A:C
    If plage Is Nothing Then Exit Sub 'sécurité
    '---mémorisation des couleurs---
    Set d = CreateObject("Scripting.Dictionary")
    For Each cel In [K1].CurrentRegion.Resize(, 1) 'à adapter
        d(cel.Font.ColorIndex) = ""
    Next cel
    '---masquage---
    Application.ScreenUpdating = False
    plage.EntireRow.Hidden = True
    For Each cel In plage
        If cel <> "" Then
            fci = cel.Font.ColorIndex
            If IsNull(fci) Then 'si coloration partielle
                For i = 1 To Len(cel)
                    If d.exists(cel.Characters(i, 1).Font.ColorIndex) Then GoTo 1
                Next i
            ElseIf d.exists(fci) Then
1               Set f = Union(IIf(n, f, cel), cel)
                n = n + 1
            End If
            If n = decharge Then f.EntireRow.Hidden = False: n = 0: Set f = Nothing
        End If
    Next cel
    If n Then f.EntireRow.Hidden = False
Else
    Rows.Hidden = False
End If
End Sub
 

Pièces jointes

  • filtre selon couleur(4).xls
    54.5 KB · Affichages: 15

Discussions similaires

Statistiques des forums

Discussions
311 735
Messages
2 082 024
Membres
101 873
dernier inscrit
excellllll