XL pour MAC Récupérer l'ensemble des lignes de couleur X dans un onglet

[BilalD]

Bonjour,

Je suis confronté à un tableau d'un comptable que j'essai de simplifier.
Chaque onglet du tableau correspond à un service de l'entreprise et des frais réalisés par ce service, le comptable a mis une couleur de police rouge pour les factures manquantes et que l'on doit lui envoyer.

J'aurai voulu créer un nouvel onglet qui regroupe toutes les lignes en rouge (une ligne = 3 colonnes : le service concerné, la date et le montant).

Je n'ai pas trouvé de moyen de faire cela avez vous une idée ?

Merci pour votre aide

 

[Phil69970]

Bonjour @BilalD et bienvenu sur XLD

J'ai pas vu ton fichier

@Phil69970

 

[BilalD]

@Phil69970 Merci pour l'accueil ! désolé oui sans doute plus simple avec un fichier.

ci-joint Onglet synthèse ou je voudrais récupérer toutes les lignes rouge.

Merci de ton aide

 

[Phil69970]

Re

Je te propose ce fichier

Pour info j'ai fait 2 versions :
1) Une version par couleur (comme tu l'as demandé)
2) Une version si dans la colonne facture il y a rien car il y a le mot "Oui" si la facture est trouvée

Merci de ton retour

@Phil69970

 

[BilalD]

waaahhhh merci beaucoup @Phil69970

Les 2 fonctions sont nickel et je vais voir à l'usage laquelle est la plus efficace.

Grand merci pour le temps que tu as consacré pour m'aider !!!

 

[BilalD]

@Phil69970 j'abuse de ton aide, mais comment je peux faire pour que d'autres feuilles soient prises en compte ?
Le fichier que j'ai envoyé était un échantillon, le vrai comporte une dizaine de feuille.

je n'ai pas trouvé ou cela se gère dans la macro

Sub Copie()
Application.ScreenUpdating = False

Dim WsDst As Worksheet, Ws As Worksheet, DerligDst&, Derlig&, i&

Set WsDst = Worksheets("Synthèse")
DerligDst = WsDst.Range("B" & Rows.Count).End(xlUp).Row + 1
WsDst.Range("B4:E" & DerligDst).ClearContents
DerligDst = WsDst.Range("B" & Rows.Count).End(xlUp).Row + 1

For Each Ws In Worksheets
    With Ws
        If .Name <> "Synthèse" Then
            Derlig = .Range("A" & Rows.Count).End(xlUp).Row
            For i = 4 To Derlig
                If .Range("A" & i).Font.ColorIndex = 3 Then
                    WsDst.Range("B" & DerligDst & ":E" & DerligDst) = .Range("A" & i & ":D" & i).Value
                    DerligDst = WsDst.Range("B" & Rows.Count).End(xlUp).Row + 1
                End If
            Next i
        End If
    End With
Next Ws
Set WsDst = Nothing
End Sub

 

[Phil69970]

Bonjour @BilalD

j'abuse de ton aide, mais comment je peux faire pour que d'autres feuilles soient prises en compte ?
Le fichier que j'ai envoyé était un échantillon, le vrai comporte une dizaine de feuille.

Et as tu essayé la macro avec ton fichier et tes feuilles ?

Car en principe mon fichier fonctionne quelque soit le nombre de feuilles 😉

@Phil69970

 

[BilalD]

Bonjour pardon @Phil69970 je ne t'avais pas répondu c'est ok je n'avais pas respecté l'emplacement des données dans les nouvelles feuilles.

 

[Staple1600]

Bonsoir le fil

Histoire de varier les plaisirs
(et pour la curiosité de savoir si cela fonctionne sur Excel Mac)
Une macro qui utilise le filtre automatique

Sub Copier_par_Filtre_Couleur()
Dim ws As Worksheet
For Each ws In Worksheets
    If ws.Name <> "Synthèse" Then
        ws.[A3].CurrentRegion.AutoFilter Field:=1, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterFontColor
        With ws.AutoFilter.Range
        Set rngF = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(xlCellTypeVisible)
        End With
        rngF.Copy Sheets("Synthèse").Cells(Rows.Count, "B").End(3)(2)
        ws.AutoFilterMode = False
    End If
Next
End Sub

 

[Staple1600]

Une version paramétrable
(on peut choisir la couleur)
Fonctionne sur la base du fichier exemple
(tous les tableaux commencent toujours en A3 sur les feuilles à traiter)

Sub Traitement()
'ici on peut choisir la couleur
'ici: rouge
Copie_Couleur vbRed
End Sub
Private Sub Copie_Couleur(couleur)
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "Synthèse" Then
ws.[A3].CurrentRegion.AutoFilter 1, couleur, 9
Set rngF = ws.AutoFilter.Range.Offset(1, 0).Resize(ws.AutoFilter.Range.Rows.Count - 1, ws.AutoFilter.Range.Columns.Count).SpecialCells(12)
rngF.Copy Sheets("Synthèse").Cells(Rows.Count, "B").End(3)(2): ws.AutoFilterMode = 0
End If
Next
End Sub

 

[mapomme]

Bonjour à tous 😉,

Surtout pour vous saluer, une autre version (avec commentaires) :

Sub QueLesRouges()
Dim sh, n&, der&, i&, j&, f
  
   For Each sh In Worksheets     'calcul d'un majorant n du nombre de lignes du tableau résultat
      If sh.Name <> Sheets("Synthèse").Name Then n = n + sh.UsedRange.Rows.Count
   Next sh
   ReDim t(1 To n, 1 To 4): n = 0      'déclaration et dimmensionnement du tableau résultat
   For Each sh In Worksheets           'pour chaque feuille de calcul
      If sh.Name <> Sheets("Synthèse").Name Then   'seulement si on ne traite pas la feuille "Synthèse"
         With sh                                   'avec la feuille qu'on traite
            If .FilterMode Then .ShowAllData       'si filtre, on affiche tout - pour bon fonctionnement de End(xlup)
            der = .Cells(Rows.Count, "a").End(xlUp).Row  'dernière ligne de données de la la feuille sh
            If der >= 4 Then                             'si il y a au moins une ligne source
               f = .Range("a4:d" & der)                  'on lit le tableau source de sh
               For i = 1 To UBound(f)                    'boucle sur le tableau source
                  'si la police est rouge, on recopie la ligne source (depuis f) dans la ligne suivante du tableau résultat (t)
                  If .Cells(3 + i, "a").Font.Color = vbRed Then: n = n + 1: For j = 1 To 4: t(n, j) = f(i, j): Next
               Next i
            End If
         End With
      End If
   Next sh
   Application.ScreenUpdating = False                    'on fige l'affichage (plus rapide)
   With Sheets("Synthèse")                               'avec la feuille "Synthèse"
      .Activate                                          'on active la feuille
      If .AutoFilterMode Then Cells.AutoFilter           'si autofiltre, on l'enlève
      .Range("b5:e" & Rows.Count).Clear                  'on efface les résultats précédents (ligne 5 à la dernière ligne)
      .Range("b5").Resize(n, 4) = t                      'on transfère les n premières lignes résultats de t sur la feuille
      .Range("d5").Resize(n).NumberFormat = "# ##0.00"   'on formate la colonne des montants (deux décimales)
      .Range("b4").Resize(n + 1, 4).AutoFilter           'on "autofiltre" le résultat
   End With
End Sub

 

[Staple1600]

Bonjour mapomme

Tu n'aimes pas les nouvelles options offertes par le Filtre automatique ?
Ou le dimanche est dans tes contrées, le jour réservé à la célébrations des Arrays ?
Une sorte de Jour de L'Array Céleste
Avec en bonus, du commentaire de bon aloi, comme disait Jacques, ce qui ne gâche rien au plaisir de se croiser sur XLD 😉

PS: Si jamais un Maciste passait par ici, puisse-t-il me dire ce qu'il en est de mon interrogation du message#9.
Merci

 

[mapomme]

Bonjour @Staple1600 (désormais PQiste ?) 😉.

La pomme bleue ne connaissant pas Excel sur les machines de la pomme multicolore, je suis resté basique pour mon code.

Quelles sont donc les nouvelles options des filtres automatiques ?

nota : quand tu parles de la nue cosmique, tu parles de celle-ci : Array Celeste 😜 ?

 

[Staple1600]

Re

@mapomme
Bah on peut filtrer sur la couleur comme le montre mon code VBA
(C'est assez récent, non ?)
Voir ici pour les détails

Filtrage par couleur de police, couleur de cellule ou jeux d'icônes - Support Microsoft

support.microsoft.com

PS: Oui, j'ai vrillé. A force de faire du prosélytisme pour le KISS, j'ai fini par me l'appliquer à moi-même.
J'essaie de moins faire de VBA et de faire dans le natif, mais je n'oublierais jamais les joies de l'Array.