somme de cellules couleur

[zamchenille]

Bonjour,
Je cherche une solution pour affecter une valeur aux cellules colorées.
Je fait des plannings et les cellules blanches et noires équivalent à 0 heures travaillées, les colorées (peu importe leur couleur ou leur contenu) équivalent à 0,5 heure. En fin de colonne je voudrais pouvoir faire le total des cellules colorées sans avoir à les compter manuellement.
Y a t'il une solution ?
Merci pour votre aide

 

[zebanx]

Bonjour Zamchenille,

Un fichier venant du génial site de Jacques Boisgontier
http://boisgontierjacques.free.fr/ (rechercher somme couleurs)

Vous n'avez plus qu'à utiliser directement ce fichier, soit recopier le code dans votre fichier et utiliser cette fonction.

xlment

 

[zamchenille]

Merci pour la réponse je vais voir si je peux l'adapter à mon planning.
Il me semble que j'ai déjà vu cette formule dans mes recherches et ça colle pas.
Mais merci quand même

 

[Johan]

Salut zamchenille, zebanx

J'ai essayé de mon côté, voici ce que ça donne :

Sub SommeCouleurs()

    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        Compteur = Total
        If Cells(i, 1).Interior.Color <> 0 And Cells(i, 1).Interior.Color <> 16777215 Then
            'MsgBox Cells(i, 1).Interior.Color
            Total = Cells(i, 1)
            Total = Total + Compteur
        End If
    Next
   
    MsgBox Total
  
End Sub

A toi de voir si cela convient

Fichier en PJ au cas où

 

[Johan]

Je viens de voir que je répondais pas tout à fait à ton besoin,

Remplace juste :

Total = Cells(i, 1)

Par

Total = 0.5

Johan

 

[zamchenille]

Je suis désolée mais soit je ne comprend pas, soit ça ne fonctionne pas.
J'ai recopié à l'identique la macro mais il y a une formule qui ne passe pas :
(If Cells(i, 1).Interior.Color <> 0 And Cells(i, 1).Interior.Color)
message : erreur de compilation: Attendu : then ou go to.

De plus , dans les cellules que je veut additionner ne figure pas forcément des nombres. Ce que je souhaite c'est qu'à partir du moment où une cellules est colorée, elle prenne la valeur de 0.5 (peu importe son contenu) afin que je puisse additionner ma colonne. Je ne sais pas si c'est assez clair et si c'est faisable. je joint un fichier pour exemple.
En attendant merci beaucoup

 

[Johan]

Re,

Tu as dû mal recopier. J'ai intégré le code dans le cas de ton fichier, on aurait dû commencer par là

La macro s'éxecute en cliquant sur le bouton

J'attends ton retour


Johan

 

[zamchenille]

Merci, vraiment, ça me rassure de savoir que c'est possible.
Mais je n'arrive pas a l'appliquer sur les autres jours de la semaine, je ne suis pas assez calée en macro.
Si ce n'est pas trop demandé, je vais modifié un planning original pour que les noms n'apparaissent pas, je vais essayé d'y inclure votre macro et je vous l'envoi pour voir ce qui ne va pas.
je suis emmené à travailler beaucoup de tableaux et il faudrait que je maitrise mieux.
j'ai cherché des cours mais il y a une logique de langage que j'ai du mal a saisir.
Je suis secrétaire, mais couturière de formation !!!!
Je m'en occupe dès lundi,
ma journée de demain est bien trop remplie je n'aurais pas le temps de m'en occuper.
Merci

 

[Johan]

Oui c'est juste une question de logique, désolé je pense jamais à commenter mes lignes de code vu que souvent les personnes qui viennent ici maîtrisent bien le VBA mais ont simplement du mal à trouver la solution.

Après c'est peut-être faisable en formule, auquel cas quelqu'un trouvera peut-être la solution, j'avoue que j'ai pas trop cherché de ce côté là

Pour ce qui est de la logique pour le lundi en colonne B ça donnait :

    For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
        Compteur1 = Total1
        If Cells(i, 2).Interior.Color <> 0 And Cells(i, 2).Interior.Color <> 16777215 Then
            Total1 = 0.5
            Total1 = Total1 + Compteur1
        End If
    Next

"i" c'est une variable qui compte le nombre de ligne jusqu'à trouver la dernière cellule non vide de la colonne, s'il y a 5 lignes i vaudra successivement 1 puis 2 puis 3 puis 4 et enfin 5. Je l'ai fait partir de 2 car la première ligne est l'entête de la colonne ("Lundi") dont on ne doit pas tenir compte

Cells(i,2) veut dire Cellule(ligne i, colonne 2) donc B => B2, B3, B4, B5...

Je regarde si le code couleur de la cellule. Si c'est différent de (<>) noir (0) ou de blanc (16777215) je compte 0.5 que je place à chaque boucle dans ma variable "compteur" pour garder en mémoire le résultat précédent.

Pour faire mardi dans la colonne C j'aurais juste à créer la variable j (ou peu importe son nom) et à me baser sur "Cells(j,3) car colonne C et nommer les compteurs et totaux différement (Total2, Compteur2) des calculs de la colonne B

Voila ^^

Je suis en congés à partir de demain pour 3 semaines mais j'essaierai de jeter un oeil sur le sujet la semaine prochaine, sinon quelqu'un d'autre passera surement par là !

Bonne chance


Johan

 

[zamchenille]

Bonjour,
Merci pour les explications, c'est un peu plus clair pour moi.
J'ai refait à l'identique mais j'ai un soucis pour l'appliquer sur mardi, le samedi et le dimanche.
voilà la copie de ce que j'ai fait :

'Lundi
For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
Compteur1 = Total1
If Cells(i, 2).Interior.Color <> 0 And Cells(i, 2).Interior.Color <> 16777215 Then
Total1 = 0.5
Total1 = Total1 + Compteur1
End If
Next


'Mardi
For j = 2 To Cells(Rows.Count, 3).End(xlUp).Row
Compteur2 = Total2
If Cells(j, 3).Interior.Color <> 0 And Cells(j, 3).Interior.Color <> 16777215 Then
Total2 = 0.5
Total2 = Total2 + Compteur2
End If
Next


'Mercredi
For k = 2 To Cells(Rows.Count, 4).End(xlUp).Row
Compteur3 = Total3
If Cells(k, 4).Interior.Color <> 0 And Cells(k, 4).Interior.Color <> 16777215 Then
Total3 = 0.5
Total3 = Total3 + Compteur3
End If
Next


'jeudi
For l = 2 To Cells(Rows.Count, 5).End(xlUp).Row
Compteur4 = Total4
If Cells(l, 5).Interior.Color <> 0 And Cells(l, 5).Interior.Color <> 16777215 Then
Total4 = 0.5
Total4 = Total4 + Compteur4
End If
Next


'vendredi

For m = 2 To Cells(Rows.Count, 6).End(xlUp).Row
Compteur5 = Total5
If Cells(m, 6).Interior.Color <> 0 And Cells(m, 6).Interior.Color <> 16777215 Then
Total5 = 0.5
Total5 = Total5 + Compteur5
End If
Next


'samedi

For n = 2 To Cells(Rows.Count, 7).End(xlUp).Row
Compteur6 = Total6
If Cells(n, 7).Interior.Color <> 0 And Cells(n, 7).Interior.Color <> 16777215 Then
Total6 = 0.5
Total6 = Total6 + Compteur6
End If
Next


'dimanche

For o = 2 To Cells(Rows.Count, 8).End(xlUp).Row
Compteur7 = Total7
If Cells(o, 8).Interior.Color <> 0 And Cells(l, 8).Interior.Color <> 16777215 Then
Total7 = 0.5
Total7 = Total7 + Compteur7
End If
Next


End Sub


Elle est où l'erreur ?
Merci
Sinon, c'est génial !!!

 

[zebanx]

Bonjour,

Une idée de boucle en reprenant l'exemple ci-dessus.
Je ne me souviens par contre plus comment on peut l'automatiser à chaque changement de couleurs (essayé de retrouver quelques privatesub() sur la feuille mais ça ne fonctionne pas), peut-être qu'une aide viendra compléter cela.
Il y a trois couleurs qui ne sont pas pris en compte (noir = 1, blanc = 2, incolore = xlnone) sinon à chaque fois, ça incrémente de 0.5.
Le nombre de colonnes n'est pas forcément figé non plus d'où l'utilisation de derligne et dercol.

Bonne journée
zebanx

Sub somme_couleur()
Dim derligne&, dercol&, a

derligne = Cells(Rows.Count, 1).End(3).Row
dercol = Cells(1, Columns.Count).End(1).Column

Range(Cells(derligne, 2), Cells(derligne, dercol)).ClearContents

For j = 2 To dercol
a = 0
For i = 2 To derligne - 1
'----si la couleur est incolore, blanche ou noir, on ne fait rien
If Cells(i, j).Interior.ColorIndex <> 1 And Cells(i, j).Interior.ColorIndex <> 2 And Cells(i, j).Interior.ColorIndex <> xlNone Then
a = a + 0.5
Else
End If
Next i
Cells(derligne, j).Value = a
Next j

End Sub

 

[zamchenille]

Bonjour,

merci beaucoup pour votre réponse, ça fonctionne très bien sur l'exemple que je vous ai donné.
Je travaille sur les vrais planning depuis ce matin avec vos lignes de codes mais je ne sais pas si sur un si grand tableau ça peut fonctionner étant donné qu'il y a des cellules fusionnées.
Je me sens toute petite de ne pas y arriver
Je vous envoi en pièce jointe le fichier original, dites moi ce qu'il faut que je fasse si cela est possible, tout ces calculs représentent un travail considérable et je gagnerai tellement de temps si ils se faisait seuls. sachant qu'il y a 52 semaines dans l'année et plus de 20 salariés à gérer.

Autre question ; la macro, une fois mise en place peut-elle être "copiée" sur une autre feuille du classeur, ou est-ce qu'il suffit juste de l'activer ?

Merci pour votre patience

 

[zebanx]

Re-

Le code suivant devrait vous convenir je l'espère

Quelques informations :
- il travaille sur la feuille active donc vous pouvez la dupliquer.
- en se basant sur une recherche de chaque cellule contenant H/JOUR
- dans des tableaux normés à chaque fois (ie : 7 jours pour les colonnes et 26 découpages de tranche horaires).
--> si vous modifiez la matrice, il faudra modifier le code !
- la fusion devrait fonctionner. Comme vous le verrez sur le fichier, 12 cases fusionnées en jaune sont comptabilisées comme 6 heures et pas comme 1/2 heure.
- la macro n'est pas automatique, il faut à chaque fois appuyer sur un bouton de mise à jour (en haut à gauche)

zebanx

Sub somme_couleur_planning()
Dim derligne&, dercol&, a
Dim cel As Range
Dim FirstAdress As String

On Error Resume Next
        
'--avec la feuille active
With ActiveSheet.Range("a1:y500")
    Set cel = Cells.Find(What:="H/JOUR", LookAt:=xlWhole)  '--recherche de "H/JOUR"
    If Not cel Is Nothing Then
    firstAddress = cel.Address

        Do
            celcol = cel.Column  '-- identification de la ligne et de la colonne trouvée
            celrow = cel.Row
            For j = celcol + 1 To celcol + 7   '-- boucle sur les 7 colonnes suivantes
            a = 0

            For i = celrow - 1 To celrow - 26 Step -1
            '----si la couleur est incolore, blanche ou noire, on ne fait rien
                If Cells(i, j).Interior.ColorIndex <> 1 And Cells(i, j).Interior.ColorIndex <> 2 And Cells(i, j).Interior.ColorIndex <> xlNone Then
                a = a + 0.5
                Else
                End If
                Next i
            Cells(celrow, j).Value = a
            Next j
           
            Set cel = .FindNext(cel)
         Loop While Not cel Is Nothing And cel.Address <> firstAddress
      End If
End With

End Sub

 

[job75]

Bonjour zamchenille, johan, zebanx,

Je suis étonné que vous n'utilisiez pas une fonction VBA, c'est vraiment enfantin :

Function CompteCouleur(r As Range)
Application.Volatile
Dim n&
For Each r In r
    n = r.Interior.Color
    If n <> 16777215 And n <> 0 Then CompteCouleur = CompteCouleur + 1
Next
End Function

Le code est à placer impérativement dans un module standard.

Fichier .xlsm joint, pour chaque semaine les formules ont été créées par copier-coller.

A+

 

[job75]

Petite remarque en passant : le 3 octobre 2018 n'est pas un lundi mais un mercredi