Compter cellules selon couleur, macro à optimiser [Résolu/Fermé]

Signaler
Messages postés
50
Date d'inscription
mercredi 28 décembre 2016
Statut
Membre
Dernière intervention
13 mai 2020
-
Messages postés
50
Date d'inscription
mercredi 28 décembre 2016
Statut
Membre
Dernière intervention
13 mai 2020
-
Bonjour à tous,

J'ai construit une macro permettant de compter les cellules selon leurs couleurs de remplissage.
Tout fonctionne parfaitement.

Mais maintenant, je souhaite que seul une cellule par colonne soit comptée.
Ainsi, si dans une même colonne, plusieurs cellules ont la couleur de fond cherchée, elle ne doivent compter que pour 1.

J'ai donc repris la macro en insérant les numéros de colonnes des cellules ayant la couleur cherchée dans un tableau.

A la fin de la recherche, je tri le tableau puis compte les éléments distincts.

Tout fonctionne bien, mais lorsqu'il y a beaucoup de calculs à faire, c'est un peu long...
Alors que la première macro sans ce travail sur les colonnes s’exécutait très vite...

C'est là que je m'en remets à votre expertise :
Est-il possible d'optimiser ma macro pour la rendre plus rapide ?
Changer la logique ?

A moins que dans tous les cas, cela demandera un peu de temps...


PS : J'ai tenté une autre logique, en parcourant le tableau avant d'ajouter un élément nouveau afin de vérifier que celui-ci n'existait pas, mais c'est pire en temps d’exécution.

Merci !
-NoeGo-

Code :
Option Base 1
Option Explicit

Function NbCellulesSelonCouleur(Plage As Range, Couleur As Range) As Long
'Compte le nombre de cellules d'une couleur donnée dans une plage donnée sans doublons sur la colonne

Application.Volatile 'Recalcule à chaque modification du fichier la valeur de la fonction

Dim Cellule As Range
Dim Tableau() As Integer
Dim i As Integer, j As Integer
Dim ecr As Integer
ecr = 1

For Each Cellule In Plage 'recherche de la couleur dans toutes les cellules de la plage
If Cellule.MergeArea(1, 1).Address = Cellule.Address And Cellule.Interior.Color = Couleur.Interior.Color Then 'le premier test vérifie évite de compter 2 fois une cellule fusionnée
ReDim Preserve Tableau(1 To ecr) 'j ajoute une dimension au tableau pour écrire le numéro de la colonne trouvée
Tableau(ecr) = Cellule.Column
ecr = ecr + 1 'j augmente ecr pour la prochaine cellule trouvée
End If
Next Cellule

If ecr > 1 Then 'si ecr est superieur alors il y a au moins une cellule trouvee
Dim str As String 'je commence par trier le tableau
For i = 1 To UBound(Tableau)
For j = i + 1 To UBound(Tableau)
If Tableau(i) > Tableau(j) Then
str = Tableau(i)
Tableau(i) = Tableau(j)
Tableau(j) = str
End If
Next j
Next i

NbCellulesSelonCouleur = 1
'Calcul de n, le nombre de valeurs
For i = 1 To UBound(Tableau) - 1 'je parcours le tableau et compte le nombre de valeurs distinctes dans celui-ci
If Tableau(i) <> Tableau(i + 1) Then
NbCellulesSelonCouleur = NbCellulesSelonCouleur + 1
End If
Next i

Else 'Sinon aucune valeur trouve donc la fonctionne retourne 0
NbCellulesSelonCouleur = 0
End If


End Function


4 réponses

Messages postés
16373
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
22 janvier 2021
3 115
Bonjour,

As tu essayé de parcourir ta plage par un objet dictionary ?

un principe:

dim dico as object

set Dico=createobject("scripting.dictionary")

for each cellule in plage
Couleur=cellule.interior.color

If not dico.exists(couleur) Then dico.add couleur, ""

next

Tableau=dico.keys


A adapter bien sûr à ton contexte (tableau reste à base 0 malgré ton option base 1)

discussion déplacée dans le forum programmation VBA
 Michel
Messages postés
50
Date d'inscription
mercredi 28 décembre 2016
Statut
Membre
Dernière intervention
13 mai 2020
12
Bonjour Michel,

Merci pour cette suggestion.
Je ne connaissais pas l'objet dictionary.

Malheureusement, au final le temps d’exécution ne change que peu.

Je ne suis pas sûr qu'on puisse faire beaucoup mieux...

Le nouveau code :
Option Explicit

Function NbCellulesSelonCouleur(Plage As Range, Couleur As Range) As Long
'Compte le nombre de cellules d'une couleur donnée dans une plage donnée

Application.Volatile 'Recalcule à chaque modification du fichier la valeur de la fonction

Dim Cellule As Range
Dim Dico As Object

NbCellulesSelonCouleur = 0

Set Dico = CreateObject("scripting.dictionary")

For Each Cellule In Plage
    If Cellule.MergeArea(1, 1).Address = Cellule.Address And Cellule.Interior.Color = Couleur.Interior.Color Then
        If Not Dico.exists(Cellule.Column) Then
            Dico.Add Cellule.Column, ""
            NbCellulesSelonCouleur = NbCellulesSelonCouleur + 1
        End If
    End If
Next Cellule

End Function
Messages postés
16373
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
22 janvier 2021
3 115
déjà utilise
application.screenupdating=False

Les cellules fusionnées sont un véritable fléau en VBA à éviter au maximum
Messages postés
12235
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
6 janvier 2021
2 557
Bonjour NoeGo, Michel,

Pas certain que ScreenUpdating diminue le temps d'exécution dans ce cas précis.
Par contre, sans cellules fusionnées, on pourrait faire beaucoup plus rapide.

Plage ==> Var Tableau ==> Dictionary (ou Collection)

Autre conseil, placer Couleur.Interior.Color dans une variable en début de fonction.
Messages postés
50
Date d'inscription
mercredi 28 décembre 2016
Statut
Membre
Dernière intervention
13 mai 2020
12
Bonjour à vous,

Merci beaucoup pour vos conseils.
Malheureusement, j'ai créé la macro pour un chef, et il veut absolument fusionner des cellules, donc je dois m'adapter...

Finalement, le temps d’exécution est tout à fait acceptable avec les aménagements que vous m'avez proposé.
Et surtout, j'ai l'impression que sur le réseau c'est plus rapide qu'en VPN de chez moi !

Encore merci,
-NoeGo-