Logo GNT
Actualités Tests & Guides Bons Plans
GTA 6 iPhone 17 Copilot Switch 2 Temu ChatGPT Tesla
OVH Cloud OVH Cloud
Entraide Applications Microsoft Office Excel Compter les cellules d'une même couleur avec SUMPRODUCT en VBA

Compter les cellules d'une même couleur avec SUMPRODUCT en VBA

18 réponses
Avatar
Apitos
Bonjour =E0 tous,

En colonne A, j'aimerais compter les cellules d'une m=EAme couleur (ici jau=
ne=3D6), dans des sous-ensembles pr=E9d=E9finies en utilisant la fonction S=
OMMEPROD en VBA, pour =E9viter les boucles imbriqu=E9es :

'----
Cells(i,2).Formula =3D "=3DSUMPRODUCT((" & Plage & ">=3D" & Tmp(0) & ")*(" =
& Plage & "<=3D" & Tmp(1) & ")*(" & Plage.Interior.ColorIndex & "=3D6)*1)"
'------

http://cjoint.com/?BJem6GDUSC1

Plage : A2:A2000
tmp(0) : valeur Min du sous-ensemble
tmp(1) : valeur Max du sous-ensemble

Merci d'avance.
Signaler un problème avec ce contenu

10 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
1 2
Avatar
Jacquouille
Bonjour
=NB.SI(A:A;">=0")-NB.SI(A:A;">5")
Auteurs : Jacques Chaussard, ChrisV tiré de Excelabo.net de Misange
Jacquouille

" Le vin est au repas ce que le parfum est à la femme."
"Apitos" a écrit dans le message de groupe de discussion :




Bonjour à tous,

En colonne A, j'aimerais compter les cellules d'une même couleur (ici
jaune=6), dans des sous-ensembles prédéfinies en utilisant la fonction
SOMMEPROD en VBA, pour éviter les boucles imbriquées :

'----
Cells(i,2).Formula = "=SUMPRODUCT((" & Plage & ">=" & Tmp(0) & ")*(" & Plage
& "<=" & Tmp(1) & ")*(" & Plage.Interior.ColorIndex & "=6)*1)"
'------

http://cjoint.com/?BJem6GDUSC1

Plage : A2:A2000
tmp(0) : valeur Min du sous-ensemble
tmp(1) : valeur Max du sous-ensemble

Merci d'avance.
Avatar
Apitos
Bonjour Jaquouille,

Mais ce code ne prend en compte la couleur de la cellule !
Avatar
J
Bonjour
Sub cptcouleur()
coul = Range("a1").Interior.ColorIndex
For Each cell In Selection
If cell.Interior.ColorIndex = coul Then
cpt = cpt + 1
End If
Next
MsgBox "la sélection contient " & cpt & " cellules de couleur"
End Sub

En mettant A1 de la couleur cherchée, le résultat est dans un MsgBox.
Pour le renvoyer dans une cellule :
Range("B1")=cpt
'de camille


ou une fonction :
Function CountRed(Inrange As Range)
CountRed = 0
For Each cell In Inrange
If cell.Interior.ColorIndex = 3 Then
CountRed = CountRed + 1
End If
Next
End Function

Si cela peut aider
J@@

Le 04/10/2012 12:30, Apitos a écrit :
Bonjour Jaquouille,

Mais ce code ne prend en compte la couleur de la cellule !

Avatar
Jacquouille
Salut
Très content de te revoir.
Je me permets d'attirer l'attention (d'autres l'ont fait pour moi, dans une
vie antérieure) sur le fait que:
Soit les cellules sont coloriées à la main, suivant un critère bien
défini.( ex: si valeur plus >= 0 et <=5), mais "ERRARE HUMANUM EST" et il
sera toujours possible qu'une erreur se glisse dans le pinceau.
Soit la couleur est issue d'une MEFC et là, je ne suis pas certain du
comptage.
Dès lors, pourquoi ne pas compter directement les cellules qui répondent aux
critères, sans passer par la couleur?
Cette suggestion s'adresse plus au demandeur qu'au bénévole répondeur. -)))

PS : J'ai aussi remarqué que les couleurs varient souvent d'un PC à l'autre,
lorsque le fichier est lu par des personnes différentes. Dans ce cas, on
m'avait conseillé de prendre plutôt le système RGB (C.Interior.ColorIndex =
38 ' (rgb255,153,204), mieux adapté aux nuances.

Au bon plaisir.
Jacquouille

" Le vin est au repas ce que le parfum est à la femme."
"J @@" a écrit dans le message de groupe de discussion :
k4lmeq$2fo$

Bonjour
Sub cptcouleur()
coul = Range("a1").Interior.ColorIndex
For Each cell In Selection
If cell.Interior.ColorIndex = coul Then
cpt = cpt + 1
End If
Next
MsgBox "la sélection contient " & cpt & " cellules de couleur"
End Sub

En mettant A1 de la couleur cherchée, le résultat est dans un MsgBox.
Pour le renvoyer dans une cellule :
Range("B1")=cpt
'de camille


ou une fonction :
Function CountRed(Inrange As Range)
CountRed = 0
For Each cell In Inrange
If cell.Interior.ColorIndex = 3 Then
CountRed = CountRed + 1
End If
Next
End Function

Si cela peut aider
J@@

Le 04/10/2012 12:30, Apitos a écrit :
Bonjour Jaquouille,

Mais ce code ne prend en compte la couleur de la cellule !

Avatar
Apitos
Bonjour J@@, Jaquouille,

Merci pour réponses.

Je vois qu'il n'y a pas d'autres solutions que les boucles pour compter les cellules de la même couleur.

Or, avec cette solution, on peut remarquer une lenteur dans l'exécution d u code.

Mais bon, voila le code que j'utilise pour compter, en même temps, les ch iffres dans une plage donnée et les cellules de la même couleur pour ce tte même plage (Ici jaune=6).

'---------
Option Explicit

Sub CompteOccurences()
Dim Tb As Range, C As Range
Dim Plage As String
Dim i As Long, LasLg As Integer
Dim Tmp, Rg As Range

Application.ScreenUpdating = False
With Worksheets("Feuil1")
Set Tb = .Range("L2", .Cells(.Rows.Count, "L").End(xlUp))
Tb.Offset(0, -6).ClearContents
Plage = "$A$2:" & .Cells(.Rows.Count, "A").End(xlUp).Address
LasLg = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rg = .Range("A2:A" & LasLg)
For Each C In Tb
Tmp = Extrema(C)
If IsArray(Tmp) Then
With C
.Offset(0, -9).Value = C
With .Offset(0, -8) ' Colonne D
.Formula = "=SUMPRODUCT((" & Plage & ">=" & T mp(0) & ")*(" & Plage & "<=" & Tmp(1) & ")*1)"
.Value = .Value
End With
.Offset(0, -7) = SommeSpeciale(Rg, Tmp(0), Tmp(1), 6)
End With
End If
Next C
Tb.Offset(0, -9).Resize(, 4).Sort Key1:=Tb.Offset(0, -6).Resize(1 , 1), Order1:=xlAscending, Header:=xlNo
Tb.Offset(0, -6).ClearContents

Set Tb = Nothing
End With
End Sub

Private Function Extrema(ByVal Str As String)

Str = Replace(Str, "[", "")
Str = Replace(Str, "]", "")
If InStr(Str, "-") Then Extrema = Split(Str, "-")
End Function

Function SommeSpeciale(ByVal Rng As Range, ByVal Mn As Double, ByVal Mx As Double, ByVal ColorInd As Byte) As Long
Dim C As Range
Dim S As Long

For Each C In Rng
If C >= Mn And C <= Mx And C.Interior.ColorIndex = ColorInd T hen S = S + 1
Next C
SommeSpeciale = S
End Function
'---------

Peut-on réécrire le code pour accélérer le traitement ?

Vous pouvez trouver un lien pour tester :

http://cjoint.com/?BJgaleARJCC

Merci.
Avatar
J
Bonjour à tous
Content aussi de te revoir Jacquouille. On va bientôt faire partie des
vétérans ;-)

Et désolé Apitos, mais je n'ai pas du tout assez de compétence pour t'aider.
Bon courage
J@@


Le 05/10/2012 12:20, Apitos a écrit :
Bonjour J@@, Jaquouille,

Merci pour réponses.

Je vois qu'il n'y a pas d'autres solutions que les boucles pour compter les cellules de la même couleur.

Or, avec cette solution, on peut remarquer une lenteur dans l'exécution du code.

Mais bon, voila le code que j'utilise pour compter, en même temps,


les chiffres dans une plage donnée et les cellules de la même couleur
pour cette même plage (Ici jaune=6).

'---------
Option Explicit

Sub CompteOccurences()
Dim Tb As Range, C As Range
Dim Plage As String
Dim i As Long, LasLg As Integer
Dim Tmp, Rg As Range

Application.ScreenUpdating = False
With Worksheets("Feuil1")
Set Tb = .Range("L2", .Cells(.Rows.Count, "L").End(xlUp))
Tb.Offset(0, -6).ClearContents
Plage = "$A$2:" & .Cells(.Rows.Count, "A").End(xlUp).Address
LasLg = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rg = .Range("A2:A" & LasLg)
For Each C In Tb
Tmp = Extrema(C)
If IsArray(Tmp) Then
With C
.Offset(0, -9).Value = C
With .Offset(0, -8) ' Colonne D
.Formula = "=SUMPRODUCT((" & Plage & ">=" & Tmp(0) & ")*(" & Plage & "<=" & Tmp(1) & ")*1)"
.Value = .Value
End With
.Offset(0, -7) = SommeSpeciale(Rg, Tmp(0), Tmp(1), 6)
End With
End If
Next C
Tb.Offset(0, -9).Resize(, 4).Sort Key1:=Tb.Offset(0, -6).Resize(1, 1), Order1:=xlAscending, Header:=xlNo
Tb.Offset(0, -6).ClearContents

Set Tb = Nothing
End With
End Sub

Private Function Extrema(ByVal Str As String)

Str = Replace(Str, "[", "")
Str = Replace(Str, "]", "")
If InStr(Str, "-") Then Extrema = Split(Str, "-")
End Function

Function SommeSpeciale(ByVal Rng As Range, ByVal Mn As Double, ByVal Mx As Double, ByVal ColorInd As Byte) As Long
Dim C As Range
Dim S As Long

For Each C In Rng
If C >= Mn And C <= Mx And C.Interior.ColorIndex = ColorInd Then S = S + 1
Next C
SommeSpeciale = S
End Function
'---------

Peut-on réécrire le code pour accélérer le traitement ?

Vous pouvez trouver un lien pour tester :

http://cjoint.com/?BJgaleARJCC

Merci.
Avatar
Apitos
Bonjour J @@,

merci pour ton passage.
Avatar
Jacquouille
Bonjour
Je compte environ 44 lignes de code, dont je ne saisis pas plus de la
moitié.
Voici ce que je te propose:
--------------------
Sub compter_cel_color()
Dim compteur As Variant
compteur = 0
For Each C In Range("a1:a20000")
If C.Interior.ColorIndex = 6 Then compteur = compteur + 1
Next
[j1] = compteur
End Sub
-----------------------
Il est évident que tu peux bricoler et améliorer, notamment en introduisant
un derL pour définir la longueur de la plage en (A:A).
------------------------
Ce que je te propose:
D'abord, expliquer ce qu'il y a dans tes colonnes.
Ensuite, expliquer clairement ce que tu veux.
Que tu colories certaines cel, c'est bien, cela est très visuel. Je suis
adepte de la couleur.
Mais, que tu veuilles compter le nombre de cel en couleur, là je crie
"Attention". Voir mon post précédent.


Jacquouille

" Le vin est au repas ce que le parfum est à la femme."
"Apitos" a écrit dans le message de groupe de discussion :


Bonjour J@@, Jaquouille,

Merci pour réponses.

Je vois qu'il n'y a pas d'autres solutions que les boucles pour compter les
cellules de la même couleur.

Or, avec cette solution, on peut remarquer une lenteur dans l'exécution du
code.

Mais bon, voila le code que j'utilise pour compter, en même temps, les
chiffres dans une plage donnée et les cellules de la même couleur pour cette
même plage (Ici jaune=6).

'---------
Option Explicit

Sub CompteOccurences()
Dim Tb As Range, C As Range
Dim Plage As String
Dim i As Long, LasLg As Integer
Dim Tmp, Rg As Range

Application.ScreenUpdating = False
With Worksheets("Feuil1")
Set Tb = .Range("L2", .Cells(.Rows.Count, "L").End(xlUp))
Tb.Offset(0, -6).ClearContents
Plage = "$A$2:" & .Cells(.Rows.Count, "A").End(xlUp).Address
LasLg = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rg = .Range("A2:A" & LasLg)
For Each C In Tb
Tmp = Extrema(C)
If IsArray(Tmp) Then
With C
.Offset(0, -9).Value = C
With .Offset(0, -8) ' Colonne D
.Formula = "=SUMPRODUCT((" & Plage & ">=" & Tmp(0) &
")*(" & Plage & "<=" & Tmp(1) & ")*1)"
.Value = .Value
End With
.Offset(0, -7) = SommeSpeciale(Rg, Tmp(0), Tmp(1), 6)
End With
End If
Next C
Tb.Offset(0, -9).Resize(, 4).Sort Key1:=Tb.Offset(0, -6).Resize(1,
1), Order1:=xlAscending, Header:=xlNo
Tb.Offset(0, -6).ClearContents

Set Tb = Nothing
End With
End Sub

Private Function Extrema(ByVal Str As String)

Str = Replace(Str, "[", "")
Str = Replace(Str, "]", "")
If InStr(Str, "-") Then Extrema = Split(Str, "-")
End Function

Function SommeSpeciale(ByVal Rng As Range, ByVal Mn As Double, ByVal Mx As
Double, ByVal ColorInd As Byte) As Long
Dim C As Range
Dim S As Long

For Each C In Rng
If C >= Mn And C <= Mx And C.Interior.ColorIndex = ColorInd Then S =
S + 1
Next C
SommeSpeciale = S
End Function
'---------

Peut-on réécrire le code pour accélérer le traitement ?

Vous pouvez trouver un lien pour tester :

http://cjoint.com/?BJgaleARJCC

Merci.
Avatar
Apitos
Bonsoir Jaquouille,

L'exemple fourni, montre bien les données à traiter.

Voila un nouveau code, qui peut intéresser plus d’un, testé sur 1984 8 lignes en colonne A, qui me fait gagner plus de 6 minutes en temps d'ex écution.

Le code exposé en lien dans l'exemple s'exécute en 419,5625 secondes.

Le code suivant est exécuté en 18,453125 secondes.

'----------------
Option Explicit

Sub CompteOccurences()
Dim Tb As Range, Rg As Range, c As Range
Dim Tmp
Dim start As Single

'en début de la macro
start = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Feuil1")
Set Rg = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
For Each c In Rg
If c.Interior.ColorIndex = 6 Then c.Offset(0, 50) = 1
Next c

Set Tb = .Range("L2:L" & .Cells(.Rows.Count, "L").End(xlUp).Row)
For Each c In Tb
Tmp = Extrema(c)
If IsArray(Tmp) Then
c.Offset(0, -9).Value = c.Value 'Colonne C
With c.Offset(0, -8) ' Colonne D
.Formula = "=SUMPRODUCT((" & Rg.Address & ">=" & Tmp(0) & ")*(" & Rg.Address & "<=" & Tmp(1) & ")*1)"
.Value = .Value
End With
With c.Offset(0, -7) ' Colonne E
.Formula = "=SUMPRODUCT((" & Rg.Address & ">=" & Tmp(0) & ")*(" & Rg.Address & "<=" & Tmp(1) & ")*(" & Rg.Offset(0, 50).Ad dress & "=1)*1)"
.Value = .Value
End With
c.Offset(0, -6) = Tmp(0) 'Colonne F
End If
Next c
Rg.Offset(0, 50).ClearContents
Set Rg = Nothing

Tb.Offset(0, -9).Resize(, 4).Sort Key1:=Tb.Offset(0, -6).Resize(1 , 1), Order1:=xlAscending, Header:=xlNo
Tb.Offset(0, -6).ClearContents
Set Tb = Nothing
End With
Application.Calculation = xlCalculationAutomatic
'avant end sub
[J6] = Timer - start
MsgBox "durée du traitement: " & [J6] & " secondes"
End Sub

Private Function Extrema(ByVal Str As String)
Str = Replace(Replace(Str, "[", ""), "]", "")
If InStr(Str, "-") Then Extrema = Split(Str, "-")
End Function
'-----------------

Une déférence remarquable.

Merci encore Jaquouille.
Avatar
Jacquouille
Re
- Puisque tu sembles avoir gagné 401,109375 secondes, peut-être auras-tu le
temps de mettre un "c" devant mes deux "quouille"
de "Jacquouille" ? -))
- C'est quoi, ce verbiage? Tmp = Extrema(c) et .Value = .Value

De ce que je comprends, la première partie consiste à mettre un 1 dans la
colonne AX si la cellule correspondante en colonne A est peinte en jaune.
En deuxième partie, il y a un sommeprod de Dieu le Père pour calculer Dieu
sait quoi, mais qui pourrait être la présence d'une valeur au sein d'une
plage.
Ensuite, tu effaces tout.
Excuses-moi, mais le fichier "qui est suffisamment compréhensible".....ne
l'est pas pour moi.
Cependant, si le hasard faisait que ma vision des choses soit saine, je
crois que tu irais encore dix fois plus vite en séparant ta colonne
contenant les données-bornes sur lesquelles on se réfère pour le Sommeprod.
Ensuite, tu expliques le critère utilisé pour barbouiller les cellules en
colonneA
Ensuite, un très simple:
IF [c] (de la colonneA)>= c.offset (la colonne avec la borne1) and [c]<=
c.offset(la colonne borne2)
then compteur=compteur+1:c.interior.colorindex=6
end if
next
Cela n'irait pas ?
Jacquouille

" Le vin est au repas ce que le parfum est à la femme."
"Apitos" a écrit dans le message de groupe de discussion :


Bonsoir Jaquouille,

L'exemple fourni, montre bien les données à traiter.

Voila un nouveau code, qui peut intéresser plus d’un, testé sur 19848
lignes en colonne A, qui me fait gagner plus de 6 minutes en temps
d'exécution.

Le code exposé en lien dans l'exemple s'exécute en 419,5625 secondes.

Le code suivant est exécuté en 18,453125 secondes.

'----------------
Option Explicit

Sub CompteOccurences()
Dim Tb As Range, Rg As Range, c As Range
Dim Tmp
Dim start As Single

'en début de la macro
start = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Feuil1")
Set Rg = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
For Each c In Rg
If c.Interior.ColorIndex = 6 Then c.Offset(0, 50) = 1
Next c

Set Tb = .Range("L2:L" & .Cells(.Rows.Count, "L").End(xlUp).Row)
For Each c In Tb
Tmp = Extrema(c)
If IsArray(Tmp) Then
c.Offset(0, -9).Value = c.Value 'Colonne C
With c.Offset(0, -8) ' Colonne D
.Formula = "=SUMPRODUCT((" & Rg.Address & ">=" & Tmp(0)
& ")*(" & Rg.Address & "<=" & Tmp(1) & ")*1)"
.Value = .Value
End With
With c.Offset(0, -7) ' Colonne E
.Formula = "=SUMPRODUCT((" & Rg.Address & ">=" & Tmp(0)
& ")*(" & Rg.Address & "<=" & Tmp(1) & ")*(" & Rg.Offset(0, 50).Address &
"=1)*1)"
.Value = .Value
End With
c.Offset(0, -6) = Tmp(0) 'Colonne F
End If
Next c
Rg.Offset(0, 50).ClearContents
Set Rg = Nothing

Tb.Offset(0, -9).Resize(, 4).Sort Key1:=Tb.Offset(0, -6).Resize(1,
1), Order1:=xlAscending, Header:=xlNo
Tb.Offset(0, -6).ClearContents
Set Tb = Nothing
End With
Application.Calculation = xlCalculationAutomatic
'avant end sub
[J6] = Timer - start
MsgBox "durée du traitement: " & [J6] & " secondes"
End Sub

Private Function Extrema(ByVal Str As String)
Str = Replace(Replace(Str, "[", ""), "]", "")
If InStr(Str, "-") Then Extrema = Split(Str, "-")
End Function
'-----------------

Une déférence remarquable.

Merci encore Jaquouille.
1 2