XL 2019 onglets en couleur si conditions respectées

S

sum01

XLDnaute Occasionnel
Bonjour le Forum,
Petit problème que je ne parviens à solutionner. L'objectif est de mettre en évidence les onglets avec une macro (en rouge par exemple) lorsque un seuil est dépassé. Par exemple lorsque A2 > 3% et/ou A4 > 5% sur tous les onglets du classeur Excel. Le problème est que le nombre d'onglets peut varier d'une semaine à l'autre. Ce n'est jamais un ensemble fixe. Comment alors exécuter la macro sur un nombre aléatoire d'onglets à chaque exécution ?
Merci d'avance pour votre aide et tout bon week-end
 

Pièces jointes

  • Onglets_couleurs.xlsx
    12.1 KB · Affichages: 11
Trier par date Trier par votes
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour @sum01 :),

Votre demande mérite quelques précisions:

Vous dites :
sum01 à dit:
A2 > 3% et/ou A4 > 5% sur tous les onglets du classeur Excel.
Cliquez pour agrandir...
Doit-on traiter cette condition feuille par feuille? Si une feuille répond à la condition alors on colore l'onglet de la feuille considéré ou bien (je ne le pense pas) sur toutes les feuilles la conditions doit être verifiée et dans ce cas on colore l'onglet de toutes les feuilles?

sum01 à dit:
A2 > 3% et/ou A4 > 5%
Cliquez pour agrandir...
Comment sait-on que les deux critères doivent être tous vérifiés (et) ou qu'un seul des deux critères est suffisant (ou) ?
 
Vote positif 0 Vote négatif
S

sum01

XLDnaute Occasionnel
mapomme à dit:
Bonjour @sum01 :),

Votre demande mérite quelques précisions:

Vous dites :

Doit-on traiter cette condition feuille par feuille? Si une feuille répond à la condition alors on colore l'onglet de la feuille considéré ou bien (je ne le pense pas) sur toutes les feuilles la conditions doit être verifiée et dans ce cas on colore l'onglet de toutes les feuilles?


Comment sait-on que les deux critères doivent être tous vérifiés (et) ou qu'un seul des deux critères est suffisant (ou) ?
Cliquez pour agrandir...
Bonjour Mapomme,
C'est bien cela, toutes les feuilles doivent être vérifiée et donc susceptibles d'être colorées. Votre 2ème question est très pertinente et j'espère y répondre correctement. Les deux critères doivent être vérifiés étant précisé que celui qui se trouve en A2 est plus important que celui qui se trouve en A4. On peut dès lors imaginer les cas suivants :
Si A2 > 3% et A4 > 5% alors onglets rouge
Si A2 > 3% et A4 < 5% alors onglets rouge
Si A2 < 3% et A4 > 5% alors onglets orange
Si A2 < 3% et A4 < 5% alors onglets vert
Encore merci pour votre aide
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour sum01, mapomme, le forum,

Voyez le fichier joint et cette macro dans ThisWorkbook :
VB: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Sh.[A2,A4]) Is Nothing Then Exit Sub
Dim w As Worksheet, v As Variant
For Each w In Worksheets
    w.Tab.ColorIndex = xlNone
    v = Evaluate(w.Range("A2").Text)
    If IsNumeric(v) Then If CDbl(v) > 0.03 Then w.Tab.Color = vbRed
    v = Evaluate(w.Range("A4").Text)
    If IsNumeric(v) Then If CDbl(v) > 0.05 Then w.Tab.Color = vbRed
Next
End Sub
Elle se déclenche quand on modifie ou valide A2 ou A4.

A+
 

Pièces jointes

  • Onglets_couleurs(1).xlsm
    20.2 KB · Affichages: 4
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Fichier (2) avec 3 couleurs pour tenir compte de votre post #3 :
VB: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Sh.[A2,A4]) Is Nothing Then Exit Sub
Dim w As Worksheet, v As Variant
For Each w In Worksheets
    w.Tab.Color = vbGreen
    v = Evaluate(w.Range("A2").Text)
    If IsNumeric(v) Then If CDbl(v) > 0.03 Then w.Tab.Color = vbRed: GoTo 1
    v = Evaluate(w.Range("A4").Text)
    If IsNumeric(v) Then If CDbl(v) > 0.05 Then w.Tab.Color = 49407 'orange
1 Next
End Sub
 

Pièces jointes

  • Onglets_couleurs(2).xlsm
    20.5 KB · Affichages: 9
Vote positif 0 Vote négatif
S

sum01

XLDnaute Occasionnel
Re-Bonjour Mapomme, Job75,
@job75 la macro répond pleinement aux attentes. C’est génial et cela va grandement améliorer le process. Merci à vous pour votre rapide prise en charge de cette demande pour votre redoutable efficacité. Bon week-end !
 
Vote positif 0 Vote négatif
S

sum01

XLDnaute Occasionnel
Bonjour,
En reprenant le fichier que j'utilise maintenant et qui me fait gagner un temps non négligeable, j'ai imaginé quelques modifications qui pourraient le rendre encore plus intuitif. Il y aurait par exemple 3 onglets qui ne doivent pas être être couverts par la macro. Il s'agit des onglets AA, BB, CC. Ils ne doivent pas être traités par la macro. J'ai essayé de passer par la fonction Array sans succès. car à chaque lancement de la macro, tous les onglets sont traités.
L'autre petite valeur ajoutée serait de créer un nouvel onglet (p.e. résumé) à la fin du traitement de la macro qui reprendrait tous les onglets qui ont dépassés les seuils autorisés sous la forme d'un petit tableau avec deux colonnes.
Merci encore pour votre aide et bon week-end
 

Pièces jointes

  • Onglets_couleursV3.xlsm
    21.8 KB · Affichages: 8
Vote positif 0 Vote négatif
Eric C

Eric C

XLDnaute Barbatruc
Bonjour le forum
Bonjour sum01, mapomme & job75

Tu peux placer après le For Each w, ceci qui "dit" que pour chaque feuille du classeur sauf "AA" "BB" & "CC"
VB: 
For Each w In Worksheets
     If w.Name <> "AA" And w.Name <> "BB" And w.Name <> "CC" Then
Je laisse les pros répondre à la 2ème partie de ta question
Bon dimanche à toutes & à tous
@+ Eric c
 
Vote positif 0 Vote négatif
S

sum01

XLDnaute Occasionnel
Eric C à dit:
Bonjour le forum
Bonjour sum01, mapomme & job75

Tu peux placer après le For Each w, ceci qui "dit" que pour chaque feuille du classeur sauf "AA" "BB" & "CC"
VB: 
For Each w In Worksheets
     If w.Name <> "AA" And w.Name <> "BB" And w.Name <> "CC" Then
Je laisse les pros répondre à la 2ème partie de ta question
Bon dimanche à toutes & à tous
@+ Eric c
Cliquez pour agrandir...
Bonjour Eric C:
Merci pour votre réponse. J'ai bien insérer cette ligne de code comme ceci

Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Sh.[A2,A4]) Is Nothing Then Exit Sub
Dim w As Worksheet, v As Variant
For Each w In Worksheets
If w.Name <> "AA" And w.Name <> "BB" And w.Name <> "CC" Then
w.Tab.Color = vbGreen
v = Evaluate(w.Range("A2").Text)
If IsNumeric(v) Then If CDbl(v) > 0.03 Then w.Tab.Color = vbRed: GoTo 1
v = Evaluate(w.Range("A4").Text)
If IsNumeric(v) Then If CDbl(v) > 0.05 Then w.Tab.Color = 49407 'orange
1 Next
End Sub

Mais la macro me renvoie un message d'erreur de compilatio Next sans for
 
Vote positif 0 Vote négatif
Eric C

Eric C

XLDnaute Barbatruc
Re le fil
Je n'ai pas pensé à dire que si il y a un If il doit y avoir un End If
VB: 
For Each w In Worksheets
If w.Name <> "AA" And w.Name <> "BB" And w.Name <> "CC" Then
    w.Tab.Color = vbGreen
    v = Evaluate(w.Range("A2").Text)
    If IsNumeric(v) Then If CDbl(v) > 0.03 Then w.Tab.Color = vbRed: GoTo 1
    v = Evaluate(w.Range("A4").Text)
    If IsNumeric(v) Then If CDbl(v) > 0.05 Then w.Tab.Color = 49407 'orange
    
[COLOR=rgb(184, 49, 47)][B]    End If[/B][/COLOR]

1 Next
End Sub
Bonne fin d'après-midi à toutes & à tous
@+ Eric c
 
Vote positif 0 Vote négatif
S

sum01

XLDnaute Occasionnel
Eric C à dit:
Re le fil
Je n'ai pas pensé à dire que si il y a un If il doit y avoir un End If
VB: 
For Each w In Worksheets
If w.Name <> "AA" And w.Name <> "BB" And w.Name <> "CC" Then
    w.Tab.Color = vbGreen
    v = Evaluate(w.Range("A2").Text)
    If IsNumeric(v) Then If CDbl(v) > 0.03 Then w.Tab.Color = vbRed: GoTo 1
    v = Evaluate(w.Range("A4").Text)
    If IsNumeric(v) Then If CDbl(v) > 0.05 Then w.Tab.Color = 49407 'orange
   
[COLOR=rgb(184, 49, 47)][B]    End If[/B][/COLOR]

1 Next
End Sub
Bonne fin d'après-midi à toutes & à tous
@+ Eric c
Cliquez pour agrandir...
Bonjour Eric C,
merci pour votre réponse cela fonctionne parfaitement. En recherchant sur le forum, je suis parvenu également à créer la page avec un petit tableau intégré. Le dernier pas qui me manque est comment récupéré dans le petit tableau le nom de l'onglet qui dont le % est > à 0.03. Je vais continuer à creuser.
Bonne semaine
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour sum01, Eric C, le forum,

Voyez le fichier joint et cette macro :
VB: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim liste
liste = Array("Résumé", "AA", "BB", "CC")
If IsNumeric(Application.Match(Sh.Name, liste, 0)) Or Intersect(Target, Sh.[A2,A4]) Is Nothing Then Exit Sub
Dim w As Worksheet, v1 As Variant, v2 As Variant, n%, a()
For Each w In Worksheets
    If IsError(Application.Match(w.Name, liste, 0)) Then
        w.Tab.Color = vbGreen
        v1 = Evaluate(Replace(w.Range("A2").Text, ",", ".")) 'virgule remplacée par le point
        v2 = Evaluate(Replace(w.Range("A4").Text, ",", ".")) 'virgule remplacée par le point
        If IsNumeric(v1) Then If CDbl(v1) > 0.03 Then w.Tab.Color = vbRed: GoTo 1
        If IsNumeric(v2) Then If CDbl(v2) > 0.05 Then w.Tab.Color = 49407 'orange
1       If w.Tab.Color <> vbGreen Then
            n = n + 1
            ReDim Preserve a(1 To 3, 1 To n)
            a(1, n) = w.Name
            If w.Tab.Color = vbRed Then a(2, n) = "X"
            If IsNumeric(v2) Then If CDbl(v2) > 0.05 Then a(3, n) = "X"
        End If
    End If
Next
'---restitution du tableau---
With Sheets("Résumé")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A2] '1ère cellule de destination
        If n Then .Resize(n, 3) = Application.Transpose(a) 'Transpose est limitée à 65536 lignes
        .Offset(n).Resize(Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
    End With
End With
End Sub
En A2 et A4 le séparateur décimal peut être le point ou la virgule.

A+
 

Pièces jointes

  • Onglets_couleursV3.xlsm
    29.2 KB · Affichages: 8
Vote positif 0 Vote négatif
S

sum01

XLDnaute Occasionnel
job75 à dit:
Bonjour sum01, Eric C, le forum,

Voyez le fichier joint et cette macro :
VB: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim liste
liste = Array("Résumé", "AA", "BB", "CC")
If IsNumeric(Application.Match(Sh.Name, liste, 0)) Or Intersect(Target, Sh.[A2,A4]) Is Nothing Then Exit Sub
Dim w As Worksheet, v1 As Variant, v2 As Variant, n%, a()
For Each w In Worksheets
    If IsError(Application.Match(w.Name, liste, 0)) Then
        w.Tab.Color = vbGreen
        v1 = Evaluate(Replace(w.Range("A2").Text, ",", ".")) 'virgule remplacée par le point
        v2 = Evaluate(Replace(w.Range("A4").Text, ",", ".")) 'virgule remplacée par le point
        If IsNumeric(v1) Then If CDbl(v1) > 0.03 Then w.Tab.Color = vbRed: GoTo 1
        If IsNumeric(v2) Then If CDbl(v2) > 0.05 Then w.Tab.Color = 49407 'orange
1       If w.Tab.Color <> vbGreen Then
            n = n + 1
            ReDim Preserve a(1 To 3, 1 To n)
            a(1, n) = w.Name
            If w.Tab.Color = vbRed Then a(2, n) = "X"
            If IsNumeric(v2) Then If CDbl(v2) > 0.05 Then a(3, n) = "X"
        End If
    End If
Next
'---restitution du tableau---
With Sheets("Résumé")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A2] '1ère cellule de destination
        If n Then .Resize(n, 3) = Application.Transpose(a) 'Transpose est limitée à 65536 lignes
        .Offset(n).Resize(Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
    End With
End With
End Sub
En A2 et A4 le séparateur décimal peut être le point ou la virgule.

A+
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
S

sum01

XLDnaute Occasionnel
job75 à dit:
Bonjour sum01, Eric C, le forum,

Voyez le fichier joint et cette macro :
VB: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim liste
liste = Array("Résumé", "AA", "BB", "CC")
If IsNumeric(Application.Match(Sh.Name, liste, 0)) Or Intersect(Target, Sh.[A2,A4]) Is Nothing Then Exit Sub
Dim w As Worksheet, v1 As Variant, v2 As Variant, n%, a()
For Each w In Worksheets
    If IsError(Application.Match(w.Name, liste, 0)) Then
        w.Tab.Color = vbGreen
        v1 = Evaluate(Replace(w.Range("A2").Text, ",", ".")) 'virgule remplacée par le point
        v2 = Evaluate(Replace(w.Range("A4").Text, ",", ".")) 'virgule remplacée par le point
        If IsNumeric(v1) Then If CDbl(v1) > 0.03 Then w.Tab.Color = vbRed: GoTo 1
        If IsNumeric(v2) Then If CDbl(v2) > 0.05 Then w.Tab.Color = 49407 'orange
1       If w.Tab.Color <> vbGreen Then
            n = n + 1
            ReDim Preserve a(1 To 3, 1 To n)
            a(1, n) = w.Name
            If w.Tab.Color = vbRed Then a(2, n) = "X"
            If IsNumeric(v2) Then If CDbl(v2) > 0.05 Then a(3, n) = "X"
        End If
    End If
Next
'---restitution du tableau---
With Sheets("Résumé")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A2] '1ère cellule de destination
        If n Then .Resize(n, 3) = Application.Transpose(a) 'Transpose est limitée à 65536 lignes
        .Offset(n).Resize(Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
    End With
End With
End Sub
En A2 et A4 le séparateur décimal peut être le point ou la virgule.

A+
Cliquez pour agrandir...
Bonjour Job75,
C'est tout simplement génial ! Est cela correspond encore mieux à ce que j'imaginais. Petite question, que signifie virgule remplacée par le point ? Encore merci pour ce beau code et bonne soirée
 
Vote positif 0 Vote négatif

Discussions similaires

V
  • Question
XL 2021 avoir des données dans plusieurs onglets en fonction de plusieurs conditions
Réponses
5
Affichages
158
mapomme
mapomme
R
  • Question
XL 2016 comptage d'occurences d'un mot sur différents onglets
2
Réponses
16
Affichages
1 K
danielco
D
Q
  • Question
Microsoft 365 Lenteur, calculs manuels et macro
Réponses
8
Affichages
828
QualitéNG
Q
A
  • Question
XL 2013 Utilisation de la fonction "Case" dans VBA
Réponses
12
Affichages
1 K
AnjyD
A
S
  • Question
XL 2010 VBA - macro avec 1 boucle qui alterne 1 action à conditions et 1 action sans conditions
2 3 4
Réponses
58
Affichages
6 K
Scorp0211
S
L
  • Question
XL 2016 Insertion d'une ligne si conditions respectées
Réponses
4
Affichages
1 K
Lddr
L
T
  • Question
XL 2016 Problème de conditions
Réponses
1
Affichages
847
nat54
nat54
J
  • Question
XL 2019 recherche lignes suivant plusieurs conditions VBA
Réponses
0
Affichages
555
jej154
J
N
  • Résolu(e)
Microsoft 365 Masquer un onglet selon la couleur d'une case
Réponses
7
Affichages
733
James007
James007
T
  • Résolu(e)
XL 2013 Adaptation automatique des graphique en fonction des valeurs
Réponses
1
Affichages
555
JHA
J

Membres actuellement en ligne

20 membres et 146 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 221
Messages
2 086 382
Membres
103 199
dernier inscrit
ATS1