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

BilalD

XLDnaute Nouveau
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
 

BilalD

XLDnaute Nouveau
@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
 

Pièces jointes

  • Classeur1+(1) (2).xlsx
    15.1 KB · Affichages: 4
Dernière édition:

Phil69970

XLDnaute Barbatruc
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
 

Pièces jointes

  • Copies feuilles suivant couleur V1.xlsm
    25.7 KB · Affichages: 7

BilalD

XLDnaute Nouveau
@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


VB:
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
 

Staple1600

XLDnaute Barbatruc
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
VB:
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

XLDnaute Barbatruc
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)
VB:
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

XLDnaute Barbatruc
Supporter XLD
Bonjour à tous ;),

Surtout pour vous saluer, une autre version (avec commentaires) :
VB:
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
 

Pièces jointes

  • BilalD- tableau synthèse- v1.xlsm
    27.9 KB · Affichages: 4

Staple1600

XLDnaute Barbatruc
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
 

Staple1600

XLDnaute Barbatruc

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 917
Membres
101 839
dernier inscrit
laurentEstrées