Somme horizontale puis verticale en fonction de la couleur de fond des cellules.

**graphikris** · 16/05/2013, 20h07

Bonjour,
Je dispose d'une BdD dans laquelle je suis des dates par individus.

Colonne A : Noms des individus
Colonne B à colonne G: des Dates

Toutes ces dates ont des MFC, en fonction de certains critères.
Dès que les dates dépassent le critére alors le fond des cellules concerné se colorie en ROUGE.

Je voudrais que la cellule H2 se colorie en ROUGE si au moins une des cellules des colonnes B2:G2 est ROUGE.

Idem jusqu'en H10

Puis en Cellule H11, il faudrait qu'excel fasse la somme des cellules ROUGE de H2 à H10

Cordialement,
Graphikris.

**Daniel.C** · 16/05/2013, 20h34

Bonjour,

Ce qui est plus simple que de chercher les couleurs conditionnelles, c'est d'utiliser la valeurs ou les formules gérant la MFC pour faire tes sommes.

**goldstar** · 17/05/2013, 10h32

Bonjour ,

Un truc du genre

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 
Sub maj_couleur_cellule()
 
Dim cpt_l As Integer, cpt_c As Integer
Dim nb_cellule_rouge As Integer
 
nb_cellule_rouge = 0
 
Sheets("Feuil1").Activate
 
For cpt_l = 2 To Range("a" & Rows.Count).End(xlUp).Row
    For cpt_c = 2 To 7
        If ActiveSheet.Cells(cpt_l, cpt_c).Interior.ColorIndex = 3 Then
            'Dès que les dates dépassent le critére alors le fond des cellules concerné se colorie en ROUGE.
            ActiveSheet.Cells(cpt_l, 8).Interior.ColorIndex = 3
            nb_cellule_rouge = nb_cellule_rouge + 1
            Exit For
        End If
    Next cpt_c
 
Next cpt_l
 
'Puis en Cellule H11, il faudrait qu'excel fasse la somme des cellules ROUGE de H2 à H10
ActiveSheet.Cells(11, 8) = nb_cellule_rouge
 
End Sub

Cordialement

**graphikris** · 17/05/2013, 16h05

Bonjour et merci,

çà marche bien mais un petit souci. Lorsqu'une ligne ne possèdent plus aucune date dépassée (ex : L 05) alors en H05, la cellule reste rouge, elle ne passe pas au (sans fond coloré) . Par contre le calcul final est correct.

Cordialement
Graphikris.

**graphikris** · 18/05/2013, 11h45

Bonjour,

Ci-joint un nouveau classeur avec des vraies dates et des MFC réélles,
ATTENTION / En fonction des modules, la validité est différente.

Et sinon une nouveauté par rapport au post initial, il y a désormais des cellules bleues.

L'explication est mise sur le classeur joint en Q2 feuil1

Cordialement
Graphikris.

**Daniel.C** · 18/05/2013, 13h39

Bonjour,

Essaie :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
Sub test()
'Set Var = ActiveCell.FormatConditions
Dim C As Range, Ctr As Byte, Jours As Integer, tot As Integer
With Sheets("Feuil1")
    For Each C In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp)).Offset(, 14)
        Ctr = 0
        For i = 2 To 13
            For x = 1 To .Cells(C.Row, i).FormatConditions.Count
                Set Var = .Cells(C.Row, i).FormatConditions
                Var = .Cells(C.Row, i).FormatConditions(x).Formula1
                If Left(Var, 8) = "=ESTVIDE" Then
                    If .Cells(C.Row, i) = "" Then
                        Ctr = Ctr + 1
                        Exit For
                    End If
                End If
                If InStr(1, Var, "INAPTE") > 0 Then
                    If .Cells(C.Row, i) = "INAPTE" Then
                        Ctr = Ctr + 1
                        Exit For
                    End If
                End If
                If InStr(1, Var, "AUJOURDHUI") > 0 Then
                    Jours = CInt(Split(Var, "-")(1))
                    If .Cells(C.Row, i) < Date - Jours Then
                        Ctr = Ctr + 1
                        Exit For
                    End If
                End If
            Next x
        Next i
        If Ctr = 12 Then
            C.Interior.ColorIndex = 3
            tot = tot + 1
        Else
            C.Interior.ColorIndex = xlNone
        End If
    Next C
    .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 15) = tot
End With
End Sub

**graphikris** · 18/05/2013, 15h36

Bonjour Daniel,

Je viens de tester ton code mais il ne fonctionne que pour les lignes remplies entièrement de rouge ( L26, 60, 62, 105 et 118).
Ca me donne un total de 5 Rouge en O121 Feuil1 mais rien en Feuil2 A2.
Je suis désolé ou peut etre un peu trop exigeant mais çà ne repond qu'à une partie de ma demande.

Sinon encore merci pour tout ce que tout fait sur ce forum.
En attendant une réponse, voir un code.

Merci,
Graphikris.

**Daniel.C** · 18/05/2013, 16h24

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Sub test()
 
Dim C As Range, CtrRouge As Byte, CtrBleu As Byte, Jours As Integer, TotRouge As Integer, TotBleu As Integer
With Sheets("Feuil1")
    For Each C In .Range(.[a2], .Cells(.Rows.Count, 1).End(xlUp)).Offset(, 14)
        CtrRouge = 0
        CtrBleu = 0
        For i = 2 To 14
            For x = 1 To .Cells(C.Row, i).FormatConditions.Count
                Set Var = .Cells(C.Row, i).FormatConditions
                Var = .Cells(C.Row, i).FormatConditions(x).Formula1
                If Left(Var, 8) = "=ESTVIDE" Then
                    If .Cells(C.Row, i) = "" Then
                        CtrRouge = CtrRouge + 1
                        Exit For
                    End If
                End If
                If InStr(1, Var, "INAPTE") > 0 Then
                    If .Cells(C.Row, i) = "INAPTE" Then
                        CtrBleu = CtrBleu + 1
                        Exit For
                    End If
                End If
                If InStr(1, Var, "AUJOURDHUI") > 0 Then
                    Jours = CInt(Split(Var, "-")(1))
                    If .Cells(C.Row, i) < Date - Jours Then
                        CtrRouge = CtrRouge + 1
                        Exit For
                    End If
                End If
            Next x
        Next i
        If CtrRouge + CtrBleu > 0 Then
            C.Interior.ColorIndex = 3
            TotRouge = TotRouge + 1
        ElseIf CtrBleu = 13 Then
            C.Interior.ColorIndex = 25
            TotBleu = TotBleu + 1
        Else
            C.Interior.ColorIndex = -4142
        End If
    Next C
    [Feuil2!A2] = TotRouge
    [Feuil2!B2] = TotBleu
End With
End Sub

**graphikris** · 18/05/2013, 16h33

Re,

Nickel mais je viens de réaliser que j'ai fais une erreur car pour les modules permanents (1 et 8) en colonne B et I, soit il y a une date soit c'est vide (si vide alors fond rouge).
Pour les personnes INAPTE sur tous les autres modules mais pour lesquelles il y a soit une date soit du vide pour les modules 1 et 8, alors en colonne O, le fond doit etre bleu.

Je suis totalement désolé, tu t'ai consacré à me faire un code et moi, je me suis trompé dans mes explications.

Pourrais tu me modifier le code ?

Encore Merci Daniel

Cordialement,
Graphikris.

**Daniel.C** · 18/05/2013, 16h56

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
Sub test()
Dim C As Range, CtrRouge As Byte, CtrBleu As Byte, Jours As Integer, TotRouge As Integer, TotBleu As Integer
With Sheets("Feuil1")
    For Each C In .Range(.[a2], .Cells(.Rows.Count, 1).End(xlUp)).Offset(, 14)
        CtrRouge = 0
        CtrBleu = 0
        For i = 2 To 14
            For x = 1 To .Cells(C.Row, i).FormatConditions.Count
                Set Var = .Cells(C.Row, i).FormatConditions
                Var = .Cells(C.Row, i).FormatConditions(x).Formula1
                If Left(Var, 8) = "=ESTVIDE" Then
                    If .Cells(C.Row, i) = "" Then
                        CtrRouge = CtrRouge + 1
                        Exit For
                    End If
                End If
                If InStr(1, Var, "INAPTE") > 0 Then
                    If .Cells(C.Row, i) = "INAPTE" Then
                        CtrBleu = CtrBleu + 1
                        Exit For
                    End If
                End If
                If InStr(1, Var, "AUJOURDHUI") > 0 Then
                    Jours = CInt(Split(Var, "-")(1))
                    If .Cells(C.Row, i) < Date - Jours Then
                        CtrRouge = CtrRouge + 1
                        Exit For
                    End If
                End If
            Next x
        Next i
        If CtrBleu = 11 Then
            C.Interior.ColorIndex = 25
            TotBleu = TotBleu + 1
        ElseIf CtrRouge + CtrBleu > 0 Then
            C.Interior.ColorIndex = 3
            TotRouge = TotRouge + 1
        Else
            C.Interior.ColorIndex = -4142
        End If
    Next C
    [Feuil2!A2] = TotRouge
    [Feuil2!B2] = TotBleu
End With
End Sub

**graphikris** · 18/05/2013, 17h23

Merci Daniel,

Il ne me reste plus qu'à l'adapter à ma vraie base de données.
Une question car en réalité mes modules vont de AF à AR et les identités sont en A. Car le code suivant :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

For Each C In .Range(.[a2], .Cells(.Rows.Count, 1).End(xlUp)).Offset(, 14)

me pose un souci de compréhension puisque tu mets :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Range(.[a2],

pourquoi [a2] ? car les identités n'ont pas d'intérets dans cette macro.

Où devrais je modifier le code ?

Cordialement,
Graphikris.

**Daniel.C** · 18/05/2013, 20h36

pourquoi [a2] ? car les identités n'ont pas d'intérets dans cette macro.

L'intérêt de la colonne A est qu'elle ne comporte pas de cellule vide et que de cette façon je suis sûr de récupérer la plage A2:A120 alors que, si j'avais pris une autre colonne, je n'étais pas sûr que la dernière cellule remplie soit sur la ligne 120.
Quelles seront les colonnes des modules permanents ?

**graphikris** · 19/05/2013, 11h23

Bonjour Daniel,

Les modules permanents se trouvent en Col B et I dans mon exemple maist en réalité ils sont en col AF et AM.
Dans mon vrai tableau les noms sont en col A et les modules vont de AF à AR.
De la col B à AE, j'ai d'autres données.

Cordialement, et bon Dimanche
Graphikris.

**Daniel.C** · 19/05/2013, 11h49

Bonjour,

Vérifie la macro :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Sub testReel()
Dim C As Range, CtrRouge As Byte, CtrBleu As Byte, Jours As Integer, TotRouge As Integer, TotBleu As Integer
'--------------------- vérifier le nom de la feuille -----------------------------------------------------
With Sheets("Feuil1")
    For Each C In .Range(.[a2], .Cells(.Rows.Count, 1).End(xlUp)).Offset(, 14)
        CtrRouge = 0
        CtrBleu = 0
        For i = 32 To 44
            For x = 1 To .Cells(C.Row, i).FormatConditions.Count
                Set Var = .Cells(C.Row, i).FormatConditions
                Var = .Cells(C.Row, i).FormatConditions(x).Formula1
                If Left(Var, 8) = "=ESTVIDE" Then
                    If .Cells(C.Row, i) = "" Then
                        CtrRouge = CtrRouge + 1
                        Exit For
                    End If
                End If
                If InStr(1, Var, "INAPTE") > 0 Then
                    If .Cells(C.Row, i) = "INAPTE" Then
                        CtrBleu = CtrBleu + 1
                        Exit For
                    End If
                End If
                If InStr(1, Var, "AUJOURDHUI") > 0 Then
                    Jours = CInt(Split(Var, "-")(1))
                    If .Cells(C.Row, i) < Date - Jours Then
                        CtrRouge = CtrRouge + 1
                        Exit For
                    End If
                End If
            Next x
        Next i
        If CtrBleu = 11 Then
            C.Interior.ColorIndex = 25
            TotBleu = TotBleu + 1
        ElseIf CtrRouge + CtrBleu > 0 Then
            C.Interior.ColorIndex = 3
            TotRouge = TotRouge + 1
        Else
            C.Interior.ColorIndex = -4142
        End If
    Next C
    [Feuil2!A2] = TotRouge
    [Feuil2!B2] = TotBleu
End With
End Sub

**graphikris** · 19/05/2013, 12h07

Merci Daniel, la macro fonctionne correctement mais par rapport à ma vrai BdD, il serait judiciable que que la couleur des cellules se mettent en Rouge ou Bleu ou Blanc en Colonne P au lieu de la colonne O.

Cordialement et merci pour tout le tps que tu me consacres.

Graphikris.