Filtre élabore

[C@thy]

Bonsoir le forum,

un collègue me pose une colle (voir fichier joint),

peut-on filtrer le tableau pour que seules les entités qui ont des croix partout (toutes les lignes bleu clair d'une entité) apparaissent?

En fait je ne crois pas, il me semble bien qu'il faut une macro, qu'en pensez-vous?

Merci pour vos appréciations.

Bises

C@thy

 

[C@thy]

Re : Filtre élabore

T'es carrément un chouchou!!!

En plus, tu as raison, les colonnes ont changé!!!

Merci beaucoup, c'est génial.

Je t'envoie un mp à part

Bisous bisous

C@thy

 

[pierrejean]

Re : Filtre élabore

Bonjour à tous
Bises à C@thy
Salut à Gerard

Je salue tout d'abord le beau travail de Job
Et comme j'ai une version un peu differente , je la publie (Elle n'utilise pas les couleurs mais se base sur la presence d'un code en colonne A )

 

[C@thy]

Re : Filtre élabore

Chapeau bas les artistes, mais jusqu'où s'arrêteront-ils.. 😱

Bravo, deux approches, deux excellentes solutions

Bisous bisous à vous deux et tout le fil,

C@thy

 

[C@thy]

Re : Filtre élabore

P.S. juste un petit truc qui m'avait échappé : dans les 2 feuilles de recopie il faut répéter le n0 de la ligne bleu foncé sur chaque ligne bleu clair...

bizzzzz

C@thy

 

[job75]

Re : Filtre élabore

Bonjour Pierre, heureux de te croiser 🙂

Eh bien vois-tu je n'avais pas été regardé du côté de la colonne A 🙄

Alors une autre version avec des SpecialCells et des Areas :

Sub Tri() 'touches de raccourci Ctrl+T
'on utilise le CodeName des feuilles
Dim plage As Range, R1 As Range, R2 As Range
Dim zone1 As Range, zone2 As Range, i&
With Feuil1
  Set plage = Intersect(.[A2:A65536], .[A1].CurrentRegion)
  Set R1 = .[A1]: Set R2 = .[A1]
End With
Set zone1 = plage.SpecialCells(xlCellTypeConstants)
Set zone2 = plage.SpecialCells(xlCellTypeBlanks)
For i = 1 To zone1.Count
  Set plage = zone2.Areas(i).Columns("M").Cells
  If Application.CountA(plage) = plage.Count Then
    Set R1 = Union(R1, zone1.Areas(i), zone2.Areas(i))
  Else
    Set R2 = Union(R2, zone1.Areas(i), zone2.Areas(i))
  End If
Next
Feuil2.Cells.Clear: Feuil3.Cells.Clear 'RAZ
R1.EntireRow.Copy Feuil2.[A1]: R2.EntireRow.Copy Feuil3.[A1]
End Sub

Un On Error Resume Next au début (en cas de tableau vide) me paraît superflu.

Fichier joint.

A+

 

[job75]

Re : Filtre élabore

Re C@thy,

dans les 2 feuilles de recopie il faut répéter le n0 de la ligne bleu foncé sur chaque ligne bleu clair...

OK, à la fin de la macro Tri cette macro paramétrée est appelée 2 fois :

Sub Transfert(Feuille As Worksheet, R As Range)
Dim plage As Range, zone1 As Range, zone2 As Range, i&
With Feuille
  .Cells.Clear
  R.EntireRow.Copy .[A1]
  Set plage = Intersect(.[A2:A65536], .[A1].CurrentRegion)
End With
If plage Is Nothing Then Exit Sub
Set zone1 = plage.SpecialCells(xlCellTypeConstants)
Set zone2 = plage.SpecialCells(xlCellTypeBlanks)
For i = 1 To zone1.Count
  zone2.Areas(i) = zone1.Areas(i) 'copie le N° d'EJ
Next
End Sub

Fichier (2).

Edit : ajouté If plage Is Nothing Then Exit Sub

A+

 

[C@thy]

Re : Filtre élabore

Merci Gérard, c super!!!
Mais que fais-tu encore sur XLD à cette heure-ci?
Je croyais que tu t'étais fixé une heure limite pour pouvoir partager tes soirées avec ta chère et tendre...

A bientôt !

Bises

C@thy

 

[pierrejean]

Re : Filtre élabore

Re

Très heureux egalement de te croiser Gerard

Bien que moins elegante que la solution de Gerard, je poste ma version avec tous les numeros reportés

 

[job75]

Re : Filtre élabore

Bonjour C@thy, Pierre, le forum,

Bravo pierrejean pour ta macro, elle fonctionne très bien 🙂

Mais je reviens pour un truc intéressant.

J'ai testé (Win XP, Excel 2003) ma dernière macro.

- sur 1321 lignes => durée d'exécution 0,2 seconde

- sur 13201 lignes => durée d'exécution 21 secondes.

La macro rame parce qu'il y a trop de zones disjointes dans zone1 zone2 R1 et R2.

Il faut donc alléger la mémoire en déchargeant régulèrement R1 et R2.

C'est ce que je fais dans le fichier joint.

Avec un pas de 500 sur les zones :

- sur 13201 lignes => durée d'exécution 2,4 seconde...

A+

 

[C@thy]

Re : Filtre élabore

Merci vous deux, vous êtes SUPER!!!

Bravo les gârs!!!

A bientôt

C@thy