Compter cellules selon couleur, macro à optimiser

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