Nombre de cellules ayant la même couleur de fond sur plusieurs feuilles

Bonsoir,

J'ai un classeur de 36 feuilles.

dans ces feuilles il y a des lignes dont le fond est jaune ou vert ou blanc.

est faisable d'avoir un module pour avoir par feuille ; le nom de la feuille ainsi que le nombre de cellules blanches ? bien sûr dans une autre feuille vierge.

pour connaître le nombre de feuilles j'utilise un fonction trouvée ;

Function nbfeuilles() As Integer
nbfeuilles = ThisWorkbook.Worksheets.Count
End Function.

Si vous pouviez m'aider se serait sympa de votre part.

Bonne nuit.

Bonjour,

Voici un premier essai de code, à adapter avec le nom de la nouvelle feuille, qui doit déjà exister :

Sub CellulesBlanches()

dim ws as worksheet
dim i%, CptBlanc%, CptVert%, CptJaune%, CptAutres%

for each ws in worksheets 'pour chaque feuille du classeur
    if ws.name <> "nvlfeuille" then 'si nom feuille different de nvlfeuille (!!!ADAPTER!!!)
        i = i + 1 'incrémentation i
        for each cell in ws.usedrange 'pour chaque cellule de la zone utilisée
            select case cell.interior.color 'examine les cas relatifs à la couleur de cellule
                case RGB(255, 255, 255): CptBlanc = CptBlanc + 1 'si blanc, incrémentation CptBlanc
                case RGB(0, 255, 0): CptVert = CptVert + 1 'vert
                case RGB(255, 255, 0): CptJaune = CptJaune + 1 'jaune
                case else: CptAutres = CptAutres + 1  'autres
            end select
        next cell
        sheets("nvlfeuille").range("A" & i + 1 & ":" & "F" & i + 1) = Array(ws.name, CptBlanc, CptVert, CptJaune, CptAutres, ws.usedrange.count) 'copie les données propres à ws en ligne i de nvlfeuille (ADAPTER NOM)
        end with
    end if
    CptBlanc = 0: CptVert = 0: CptJaune = 0: CptAutres = 0 'réinitialisation compteurs
next ws

Range("A1:F1").value = Array("Onglet", "Nb blanches", "Nb vertes", "Nb jaunes", "Nb autres", "Total") 'ligne entetes

end sub

Cdlt,

Merci pour ton code,

il est plus complet que ce que je pensais.

en fin de compte il suffit uniquement de comptabiliser la colonne "A".

J'ai nommer la nouvelle feuille "Compilation".

Bonne soirée.

Salut Sirbaf,
Salut 3GB,

si ce décompte est important et récurrent à ce point, il conviendrait de connaître la condition accompagnant cette couleur !
Il doit y avoir (il y a souvent) un moyen de calculer cela plus facilement!

A+

Salut sirbaf, curulis57,

Curulis, tu as raison et un simple countif pourrait probablement largement faire l'affaire... Mais bon, qui peut le plus peut le moins.

Voici le code un petit peu retouché :

Sub CellulesBlanches()

dim ws as worksheet
dim i%, CptBlanc%

for each ws in worksheets 'pour chaque feuille du classeur
    if ws.name <> "Compilation" then
        i = i + 1 'incrémentation i
        for each cell in ws.usedrange 'pour chaque cellule de la zone utilisée
            if cell.interior.color = RGB(255, 255, 255) then 'si couleur cellule vaut blanc
                CptBlanc = CptBlanc + 1 'si blanc, incrémentation CptBlanc
            end if
        next cell
        sheets("Compilation").range("A" & i + 1 & ":" & "B" & i + 1) = Array(ws.name, CptBlanc) 'copie les données propres à ws en ligne i de Compilation
    end if
    CptBlanc = 0
next ws

end sub

Cdlt,

Merci pour cette retouche.

Je teste demain matin.

Bonne nuit 3 vous tous

Merci pour la modification,

mais je ne veux le nombre de cellules que de la colonne A, car dans les feuilles j'ai également des données

dans les colonnes adjacentes, ce qui multiplie le nombre recherché. Exemple : dans une feuille j'ai 12 lignes sur 4 colonnes,

ton sub ramène 48, c'est normal puisque tu testes une plage, au lieu de 12, et et c'est 12 que je veux.

je n'ai pas su en voyer une pj aussi j'ai fait une copie d'écran.

Belle journée à toi, et encor merci de ton dévouement et de ta patience.

D'accord, petite incompréhension, en parlant de colonne A, j'ai cru que tu ne t'intéressais pas aux autres couleurs...

Il suffit de remplacer .usedrange par .usedrange.columns(1). Voici les 2 codes adaptés :

Sub CellulesBlanches()

dim ws as worksheet
dim i%, CptBlanc%, CptVert%, CptJaune%, CptAutres%

for each ws in worksheets 'pour chaque feuille du classeur
    if ws.name <> "nvlfeuille" then 'si nom feuille different de nvlfeuille (!!!ADAPTER!!!)
        i = i + 1 'incrémentation i
        for each cell in ws.usedrange.columns(1) 'pour chaque cellule de la zone utilisée
            select case cell.interior.color 'examine les cas relatifs à la couleur de cellule
                case RGB(255, 255, 255): CptBlanc = CptBlanc + 1 'si blanc, incrémentation CptBlanc
                case RGB(0, 255, 0): CptVert = CptVert + 1 'vert
                case RGB(255, 255, 0): CptJaune = CptJaune + 1 'jaune
                case else: CptAutres = CptAutres + 1  'autres
            end select
        next cell
        sheets("nvlfeuille").range("A" & i + 1 & ":" & "F" & i + 1) = Array(ws.name, CptBlanc, CptVert, CptJaune, CptAutres, ws.usedrange.count) 'copie les données propres à ws en ligne i de nvlfeuille (ADAPTER NOM)
        end with
    end if
    CptBlanc = 0: CptVert = 0: CptJaune = 0: CptAutres = 0 'réinitialisation compteurs
next ws

Range("A1:F1").value = Array("Onglet", "Nb blanches", "Nb vertes", "Nb jaunes", "Nb autres", "Total") 'ligne entetes

end sub

2è :

Sub CellulesBlanches()

dim ws as worksheet
dim i%, CptBlanc%

for each ws in worksheets 'pour chaque feuille du classeur
    if ws.name <> "Compilation" then
        i = i + 1 'incrémentation i
        for each cell in ws.usedrange.columns(1) 'pour chaque cellule de la zone utilisée
            if cell.interior.color = RGB(255, 255, 255) then 'si couleur cellule vaut blanc
                CptBlanc = CptBlanc + 1 'si blanc, incrémentation CptBlanc
            end if
        next cell
        sheets("Compilation").range("A" & i + 1 & ":" & "B" & i + 1) = Array(ws.name, CptBlanc) 'copie les données propres à ws en ligne i de Compilation
    end if
    CptBlanc = 0
next ws

end sub

Cdlt,

Bonjour à tous,

attention à l'utilisation de UsedRange !

Si A est vide, UsedRange.Columns(1) est la 1ère colonne contenant des données et non plus A.
Si je met un encadrement en A10000, UsedRange ira jusqu'à cette ligne même si toutes les cellules sont vides.
Autant de résultats faux potentiels.

eric

Bonjour eriiic,

Merci pour cette intervention. Mais c'est justement fait exprès car je n'ai pas vraiment de détail sur le contenu des 36 feuilles donc, dans le doute, on prend la colonne 1, qui a priori correspondra à la colonne A, d'après sirbaf.

En effet, tu as raison (j'espère que rien ne se trouvera en ligne 65000 ) mais, toujours en l'absence de données précises ou de région commune, c'est la solution la plus générique et simple qui m'est venue à l'esprit...

L'idéal eut été de choisir une autre couleur que le blanc probablement...

Tu peux prendre la dernière cellule saisie dans A comme fin de plage, comme d'hab quoi :-)

Oui mais j'aime pas trop , je trouve ça plus esthétique avec un usedrange, vu que je n'ai pas davantage de détails pour le moment... Alors je fais confiance à sirbaf et me dis que, en général, on ne s'amuse pas à placer une bordure en A8739 de chaque feuille, quand on en a 36...

Bonsoir à tous,

Cela ne fonctionne pas il y a des erreurs dans le code que je ne comprends pas.

Cela est dans le premier code.

Le 2ième code me ramène 1 au lieu de 12.

Quant à la bordure en A8739 énoncée par 3GB,je ne comprends pas car je n'ai mis aucune bordure.

merci de votre coopération à tous.

Bonjour,

Il faut supprimer le end with et remplacer nvlfeuille par Compilation.

Cdlt,

Re,

cela ne fonctionne toujours pas la valeur est 1 au lieu de 12.

comment fait-on pour joindre un fichier ?

Re, le problème, c'est le blanc. Avec une autre couleur, c'est plus simple car le blanc correspond à l'absence de couleur en RGB, mais pas en index de la table des couleurs...

Enfin, je ne suis pas un expert...

2 essais :

Sub CellulesBlanches()

dim ws as worksheet
dim i%, CptBlanc%

for each ws in worksheets 'pour chaque feuille du classeur
    if ws.name <> "Compilation" then
        i = i + 1 'incrémentation i
        for each cell in ws.usedrange.columns(1) 'pour chaque cellule de la zone utilisée
            if cell.interior.color = 16777215 then 'si couleur cellule vaut blanc
                CptBlanc = CptBlanc + 1 'si blanc, incrémentation CptBlanc
            end if
        next cell
        sheets("Compilation").range("A" & i + 1 & ":" & "B" & i + 1) = Array(ws.name, CptBlanc) 'copie les données propres à ws en ligne i de Compilation
    end if
    CptBlanc = 0
next ws

end sub

ou :

Sub CellulesBlanches()

dim ws as worksheet
dim i%, CptBlanc%

for each ws in worksheets 'pour chaque feuille du classeur
    if ws.name <> "Compilation" then
        i = i + 1 'incrémentation i
        for each cell in ws.usedrange.columns(1) 'pour chaque cellule de la zone utilisée
            if cell.interior.colorindex = xlnone then 'si couleur cellule vaut blanc
                CptBlanc = CptBlanc + 1 'si blanc, incrémentation CptBlanc
            end if
        next cell
        sheets("Compilation").range("A" & i + 1 & ":" & "B" & i + 1) = Array(ws.name, CptBlanc) 'copie les données propres à ws en ligne i de Compilation
    end if
    CptBlanc = 0
next ws

end sub

Si par malheur, le premier ne marche pas et que le second tombe à 11, il faudra que tu modifies le 2nd if ainsi :

if cell.interior.colorindex = xlnone or cell.interior.colorindex = 2 then

A plus,

Bonsoir et merci u tous les posts.Mais aucun ne fonctionne. j'ai changé les cellules blanches en bleus clair (RGB(0,176,240).

Même résultat.

Je voudrais vous envoyer le fichier mais je ne sais comment faire ?

Bonsoir Sirbaf,

Quand tu écris un commentaire, il y a un ruban sur lequel il y a plein d'icones dont une feuille avec un X. En cliquant dessus, tu pourras joindre un fichier.

A plus,

Merci je le vois

Il part dans quelques minutes.

Le voici