IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

Compter les cellules d'une même couleur avec SUMPRODUCT en VBA [XL-2007]


Sujet :

Macros et VBA Excel

  1. #1
    apt
    apt est déconnecté
    Membre éclairé
    Inscrit en
    Mai 2002
    Messages
    867
    Détails du profil
    Informations forums :
    Inscription : Mai 2002
    Messages : 867
    Par défaut Compter les cellules d'une même couleur avec SUMPRODUCT en VBA
    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.

  2. #2
    Expert éminent Avatar de mercatog
    Homme Profil pro
    Inscrit en
    Juillet 2008
    Messages
    9 435
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Autre

    Informations forums :
    Inscription : Juillet 2008
    Messages : 9 435
    Par défaut
    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

  3. #3
    apt
    apt est déconnecté
    Membre éclairé
    Inscrit en
    Mai 2002
    Messages
    867
    Détails du profil
    Informations forums :
    Inscription : Mai 2002
    Messages : 867
    Par défaut
    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 ?

  4. #4
    Expert éminent Avatar de mercatog
    Homme Profil pro
    Inscrit en
    Juillet 2008
    Messages
    9 435
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Autre

    Informations forums :
    Inscription : Juillet 2008
    Messages : 9 435
    Par défaut
    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

  5. #5
    apt
    apt est déconnecté
    Membre éclairé
    Inscrit en
    Mai 2002
    Messages
    867
    Détails du profil
    Informations forums :
    Inscription : Mai 2002
    Messages : 867
    Par défaut
    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.

+ Répondre à la discussion
Cette discussion est résolue.

Discussions similaires

  1. Compter les enrs d'une 2ème tables avec un ID
    Par helios399 dans le forum Requêtes
    Réponses: 4
    Dernier message: 01/03/2011, 13h03
  2. [XL-2007] Fonction calculant la somme des chiffres des cellules d'une même couleur
    Par XceSs dans le forum Macros et VBA Excel
    Réponses: 2
    Dernier message: 14/08/2010, 01h23
  3. [Dojo] Editable:false avec les cellules d'une même colonne du composant grid edit
    Par samirsaid dans le forum Bibliothèques & Frameworks
    Réponses: 0
    Dernier message: 21/05/2010, 18h53
  4. comptage de cellule d'une même couleur
    Par Vincent41 dans le forum Macros et VBA Excel
    Réponses: 5
    Dernier message: 24/01/2008, 07h45
  5. [Pygame]Supprimer/masquer les pixels d'une même couleur sur une image
    Par Mysti¢ dans le forum Programmation multimédia/Jeux
    Réponses: 2
    Dernier message: 10/05/2007, 14h40

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo