Discussion :

[apt]

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 :

Code :

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

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

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

Merci d'avance.

[mercatog]

A ma connaissance, c'est pas possible d’intégrer le format de la cellule sans fonction personnalisée.

Exemple de fonction
Rng: Range de données
Mn: Minimum
Mx: Maximum
ColorId: Index de la couleur

Code :

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

1
2
3
4
5
6
7
8
9
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

[apt]

Bonjour mercatog,

Ca marche, mais point de vue lenteur, les balayages répétitifs avec des boucles pour compter les cellules jaune, ralenti un peu l'exécution du code.

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
47
48
49
50
Option Explicit
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
 
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
                c.Offset(0, -9).Value = c
                With c.Offset(0, -8)    ' Colonne D
                    .Formula = "=SUMPRODUCT((" & Plage & ">=" & Tmp(0) & ")*(" & Plage & "<=" & Tmp(1) & ")*1)"
                    .Value = .Value
                    c.Offset(0, -7) = SommeSpeciale(Rg, Tmp(0), Tmp(1), 6)
                End With
                c.Offset(0, -6) = Tmp(0)
            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

Bonjour,

Peut-on apporter une amélioration au code pour gagner un peu de temps du traitement ?

[mercatog]

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
Option Explicit
 
Sub CompteOccurences()
Dim Tb As Range, Rg As Range, c As Range
Dim Tmp
 
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
End Sub
 
Private Function Extrema(ByVal Str As String)
 
Str = Replace(Str, "[", "")
Str = Replace(Str, "]", "")
If InStr(Str, "-") Then Extrema = Split(Str, "-")
End Function

[apt]

Bonsoir mercatog,

C'est excellent ton code

J'ai fait le test sur une plage en colonne A de 19848 lignes :

Le temps d'excution du premier code est de : 419,5625 secondes

Le temps d'execution du deuxieme code est de : 18,453125 secondes.

Une defference remarquable.

Merci encore mercatog.