Macro pour faire pourcentage de cellules jaunes/remplies

[Delux]

Bonjour a tous,

Veuillez m'excuser pour les accent, j'utilise un QWERTY.

J'ai un fichier, ou je souhaite faire un pourcentage (par ligne) du nombre de cellules Jaunes qui sont remplie.
J'ai une fonction qui me calcule le nombre de cellules jaunes dans la ligne, et je fais un counta pour calculer le nombre de cellules non-vides.

Or le CountA calcule egalement les cellules remplies qui ne sont pas jaunes.

Ma question est donc, comment faire pour ce pourcentage de cellules jaunes remplie sans prendre en compte celles qui sont remplies mais blanches?

Voici ma macro:

Sub Percentage_of_Attributes()

Dim mySource As Range
Dim myCible As Range
Dim Cel As Range
Dim dl As Integer
Dim dc As Byte

On Error Resume Next

Application.ScreenUpdating = False

Sheet1.Select

dl = Sheet1.Range("A65489").End(xlUp).Row 'derniere ligne remplie en se basant sur la colonne A
dc = Sheet1.Range("A3").End(xlToRight).Column 'derniere colonne remplie en se basant sur la ligne 4

Set mySource = Sheet1.Range(Cells(4, 3), Cells(dl, dc)) 'definit la source en utilisant les dernieres cellules remplies
Set myCible = Sheet1.Range(Cells(4, dc + 2), Cells(dl, dc + 2)) 'definit la cible

For Each Cel In myCible
      If Sheet1.Range("C" & Cel.Row).Interior.ColorIndex = 6 Then
       
Cel.Value = (Application.WorksheetFunction.CountA(Sheet1.Range(Cells(Cel.Row, 3), Cells(Cel.Row, dc))) * 100) / sommecouleur(Sheet1.Range(Cells(Cel.Row, 3), Cells(Cel.Row, dc)), Sheet3.Range("A14"))
     
      Else
       Cel.Value = 0
      End If
Next Cel

End Sub

Merci d'avance pour votre aide.

Cordialement,

Delux

 

[Modeste geedee]

Re : Macro pour faire pourcentage de cellules jaunes/remplies

Bonsour®
- quel indicateur ou critère permet de décider que telle cellule sera jaune ???
- un changement de couleur n'est pas un élément déclenchant pour un recalcul...
en conséquence un changement de couleur n'aura aucun effet sur la valeur des cellules ou formules liées.
- en cas de mise en couleur manuelle , un oubli ou erreur aura un impact difficilement identifiable lors du dénombrement.


Utiliser les MEFC pour coloration automatiques
Utiliser les mêmes critères au sain d'une formule, pour le reporting des cellules concernées.

 

[Delux]

Re : Macro pour faire pourcentage de cellules jaunes/remplies

Bonjour,

Une autre macro va chercher dans une feuille registre (que je n'ai pas mis pour eviter d'allourdir le fichier exemple) les cellules qui doivent etre jaune.
Cette macro que j'ai mis au dessus se declanche apres que toutes les cellules qui doivent etre jaune soient jaunes.
Il ne peut y avoir d'erreur a ce niveau la.

Je souhaite juste obtenir une solution pour contourner le probleme du CountA qui prend en compte les cellule blanche mais remplies.

Merci d'avance

 

[Delux]

Re : Macro pour faire pourcentage de cellules jaunes/remplies

Re,

J'ai finalement trouve une solution a mon probleme :

Sub test()
    Dim i&, dl&, a&, x&, dc&
   
    With Sheet1
        dl = Sheet1.Range("A65489").End(xlUp).Row
        dc = Sheet1.Range("A3").End(xlToRight).Column
        For i = 4 To dl
            For a = 3 To dc
                If .Cells(i, a).Interior.ColorIndex = 6 And .Cells(i, a) <> "" Then x = x + 1
            Next a
            If x <> 0 Then .Cells(i, dc + 2) = (x * 100) / sommecouleur(Sheet1.Range(Cells(i, 3), Cells(i, dc)), Sheet3.Range("A14")) Else .Cells(i, dc + 2) = 0
            x = 0
        Next i
    End With
 Sheet3.Range("F20").Value = Application.WorksheetFunction.Average(Sheet1.Range(Cells(4, dc + 2), Cells(dl, dc + 2)))
    
End Sub

Merci beaucoup

Delux