filtrer les lignes celon couleur

Bonsoir,

Je sollicite votre aide,

Je souhaite pouvoir filtrer les lignes de mon fichier,

le critère du filtrage est :

cellules aux fonds rouges situées dans une plage de plusieurs colonnes (voir le fichier joint).


Je souhaite aussi avoir la possibilité d'annuler ce filtrage pour pouvoir revisualiser toutes les lignes.

Cordialement

Guy
[file name=Classeur1_20050422192142.zip size=8318]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/Classeur1_20050422192142.zip[/file]

[Gérard DEZAMIS]

Bonsoir Guy

Comme personne n'a de solution jusqu'à présent je vais te proposer ma 'bidouille' version VBA raz des paquerettes...

Regarde si cela peut te rendre service en attendant mieux

Bien cordialement

@+ GD [file name=FiltrerCouleursGuy.zip size=15942]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/FiltrerCouleursGuy.zip[/file]

C'est parfait !!!

Merci infiniment :-))

Bon weekend

Guy

Bonjour à tous,


Gérard DEZAMIS m'a aimablement transmis cette macro qui filtre les lignes de mon fichier,


le critère du filtrage est :

cellules aux fonds rouges situées dans une plage de plusieurs colonnes (voir le fichier joint).


le tri prend 2 mins

Peut être connaissez vous des astuces pour que ce soit plus rapide.

Cordialement

[pat1545.]

Salut,

sur un fichier de test , un X en cellule D9988 (pour savoir quelle est la dernière cellule occupée ) et en fond rouge (seul modif sur le fichier de Gérard):
mon code: 2.28125
celui de gérard: 2.98437
Dell Inspiron 1.2 Gg 256 Ram
Pas tres significatif !! mais le voilà dans un module normal VBA.

Option Explicit
Sub ESSAI()
Dim rngdelete2 As Range
Dim rng2 As Range
Dim Le_parametre As Boolean
Dim Lastrowa As Integer
Dim start, stopp
start = Timer
Application.ScreenUpdating = False
With ActiveSheet
For Each rng2 In .Range(.Cells(1, 4), _
.Cells(.Rows.Count, 4).End(xlUp))
Le_parametre = rng2.Interior.ColorIndex = 3 _
Or rng2.Offset(0, 1).Interior.ColorIndex = 3 _
Or rng2.Offset(0, 2).Interior.ColorIndex = 3 _
Or rng2.Offset(0, 3).Interior.ColorIndex = 3 _
Or rng2.Offset(0, 4).Interior.ColorIndex = 3

' Le_parametre = ((rng2.Value) = rng2.Offset(1, 0).Value) And IsEmpty(rng2.Offset(1, 3))
If Le_parametre = True Then
If rngdelete2 Is Nothing Then
Set rngdelete2 = rng2.EntireRow
Else
Set rngdelete2 = Union(rngdelete2, rng2.EntireRow)
End If
End If
Next rng2
End With
If Not rngdelete2 Is Nothing Then rngdelete2.EntireRow.Hidden = True
stopp = Timer
Range('H1').Value = (stopp - start)
End Sub

attention au(x) coupure(s) de ligne
Patrick

[ChTi160]

Salut 'Pat1545
pourrais tu mettre un extrait de ton fichier?
car celà n'est pas très Clair

merci d'avance
Amicalement
Jean Marie

[pat1545.]

Salut, chTi160 et les autres

le fichier est celui de Gérard ici plus haut ou plus bas :-))
rien de plus sauf que j'ai mis une données en ligne 9900 et quelques et lancé la macro de gérard et la mienne.

c'est ce fichier là dans le fil: FiltrerCouleursGuy.zip


Patrick

[ChTi160]

Salut Guy
bonsoir le Fil
ma petite contribution
Amicalement
Jean marie [file name=FiltrerCouleursGuyV2.zip size=14573]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/FiltrerCouleursGuyV2.zip[/file]

[ChTi160]

Re

Adaptation d'un Code de Pascal76

Sub CacheV2()
Dim i As Integer
Dim derlgn As Integer
Dim x As Byte
Dim nbre As Byte
Application.ScreenUpdating = False
derlgn = Range('D65536'Â'Â').End(xlUp).Row
For i = derlgn To 3 Step -1
nbre = 0
For x = 4 To 8
If Cells(i, x).Interior.ColorIndex = 3 Then nbre = nbre + 1
Next x
If nbre < 1 Then Rows(i).Hidden = True
Next i
Application.ScreenUpdating = True
End Sub

Amicalemant
Jean Marie

[pat1545.]

Salut, Jean Marie,
petite erreur dans mon code, je masquais le contraire de ce qui était demandé;
temps exécution:
amd 1.92 Ghz/windows xp sp2:
1.15625




Sub ESSAIpmk()
Dim rngdelete2 As Range
Dim rng2 As Range
Dim Le_parametre As Boolean
Dim Lastrowa As Integer
Dim start, stopp
start = Timer
Application.ScreenUpdating = False
With ActiveSheet
For Each rng2 In .Range(.Cells(3, 4), _
.Cells(.Rows.Count, 4).End(xlUp))
Le_parametre = Not rng2.Interior.ColorIndex = 3 _
And Not rng2.Offset(0, 1).Interior.ColorIndex = 3 _
And Not rng2.Offset(0, 2).Interior.ColorIndex = 3 _
And Not rng2.Offset(0, 3).Interior.ColorIndex = 3 _
And Not rng2.Offset(0, 4).Interior.ColorIndex = 3

' Le_parametre = ((rng2.Value) = rng2.Offset(1, 0).Value) And IsEmpty(rng2.Offset(1, 3))
If Le_parametre = True Then
If rngdelete2 Is Nothing Then
Set rngdelete2 = rng2.EntireRow
Else
Set rngdelete2 = Union(rngdelete2, rng2.EntireRow)
End If
End If
Next rng2
End With
If Not rngdelete2 Is Nothing Then rngdelete2.EntireRow.Hidden = True
stopp = Timer
Range('A2').Value = stopp
Range('B2').Value = start
Range('C2').Value = (stopp - start)
End Sub