XL 2016 Compter les cellules avec des critères

[Rabeto]

Bonjour,

Quelqu'un peut m'aider à résoudre ce problématique svp,

Je souhaite compter le nombre de cellule par colonne contenant des critères différents de l'alphabet (sauf avec accent) et des chiffres (0 à 9) (ne pas compter les espaces vides sauf s'il y a double espace entre 2 valeurs)
Puis colorier ces cellules par une MFC (rouge par exemple) et mettre le nombre des cellules contenants ces critères en haut de chaque colonne.

Merci,

 

[job75]

Bonjour Rabeto,

Je n'ai été capable que de construire la MFC sur A3:C9 :

=SOMME(-ESTNA(EQUIV(STXT(A3;LIGNE(INDIRECT("1:"&NBCAR(A3)));1);Liste;0)))

La plage H2:H38 étant nommée Liste.

A+

 

[Robert]

Bonsoir le fil, bonsoir le forum,

Une proposition VBA avec le code ci-desous :

Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim PL As Range 'déclare la variable PL (PLage)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim NC As Byte 'déclare la variable NC (Nombre de Colonne)
Dim NL As Integer 'déclare la variable NL (Nombre de Ligne)
Dim J As Byte 'déclare la variable J (incrément)
Dim I As Integer 'déclare la variable I (Incrément)
Dim T As Integer 'déclare la variable T (Total)

Set O = Worksheets("Feuil1") 'définit l'onglet O
Set PL = O.Range("A1").CurrentRegion 'définit la plage PL
Set PL = PL.Offset(2, 0) 'redéfinit la plage PL (sans les deux premières lignes)
PL.Interior.ColorIndex = xlNone 'supprime les éventuelles couleurs dans la plage PL
TV = O.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
NC = UBound(TV, 2) 'definit le nombre de colonnes NC du tableau des valeurs TV
NL = UBound(TV, 1) 'definit le nombre de lignes NL du tableau des valeurs TV
For J = 1 To NC 'boucle 1 : sur toutes les colonnes J du tableau des valeurs TV
    For I = 3 To NL 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV
        For K = 1 To Len(TV(I, J)) 'boucle 3 : sur le nombre de caractères K du mot ligne I colonne J de TV
            On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
            'agit en fonction du code ASC du caractère de la boucle 3 (certains caractères génèrent une erreur car ils n'ont pas de code ASC)
            Select Case Asc(Mid(TV(I, J), K, 1))
                Case 32, 48 To 57, 65 To 90, 97 To 122 'cas correspondant à l'alphabet (majuscules et minuscule et aux numéros de 0 à 9)
                    'rien ne se passe
                Case Else 'tous les autres cas
                    O.Cells(I, J).Interior.ColorIndex = 3 'colore la cellule de rouge
                    T = T + 1 'incrémente le total T
                    Exit For 'sort de la boucle 3
            End Select 'fin de l'action en fonction du code ASC du caractère de la boucle 3
            If Err <> 0 Then 'condition : si une erreur a été générée
                O.Cells(I, J).Interior.ColorIndex = 3 'colore la cellule de rouge
                T = T + 1 'incrémente le total T
                Exit For 'sort de la boucle 3
            End If 'fin de la condition
            On Error GoTo 0 'annule la gestion des erreurs
        Next K 'prochain caractère de la boucle 3
    Next I 'prochaine ligne de la boucle 2
    O.Cells(1, J).Value = T 'renvoie le total T dans la cellule ligne 1 colonne J
    T = 0 'réinitialise T
Next J 'prochaine colonne de la boucle 1
End Sub

 

[job75]

Bonsoir Robert,

Il vaut mieux créer la MFC et utiliser VBA pour faire le comptage en A1 B1 C1 :

Private Sub Worksheet_Change(ByVal target As Range)
Dim ncol%, a&(), col%, c As Range
ncol = 3 'nombre de colonnes, à adapter
ReDim a(1 To ncol)
For col = 1 To ncol
    For Each c In UsedRange.Columns(col).Cells
        If c <> "" Then If c.DisplayFormat.Interior.Color = vbRed Then a(col) = a(col) + 1
Next c, col
'---restitution---
Application.EnableEvents = False 'désactive les évènements
[A1].Resize(, ncol) = a
Application.EnableEvents = True 'réactive les évènements
End Sub

La macro se déclenche quand on modifie ou valide une cellule quelconque.

A+

 

[Rabeto]

Bonjour job75 et Robert

Vous avez tous résolue ma question, merci beaucoup
J'ai juste une question, j'ai mis * dans une cellule quelconque pour tester d'autre caractère, cela ne fonctionne pas alors que c'est un symbole différents des critères.

 

[job75]

Bonjour Rabeto, Robert,

L'astérisque et le point d'interrogation sont des caractères génériques.

La fonction EQUIV les trouve donc forcément dans Liste.

Pour éviter cela il suffit de modifier la formule de la MFC :

=SOMME(-ESTNA(EQUIV(SUBSTITUE(SUBSTITUE(STXT(A3;LIGNE(INDIRECT("1:"&NBCAR(A3)));1);"*";"-");"?";"-");Liste;0)))

Les 2 caractères génériques sont remplacés par un caractère non listé (le tiret).

A+

 

[Rabeto]

Bonsoir,

Cela a solutionné le problème, et je vous remercie,
Ce qui me pose problème maintenant c'est que la MFC a rendu le fichier lourd, car la base sur laquelle je dois l' appliquer contient 24 colonne avec 5000 lignes

 

[job75]

Bonsoir Rabeto, Robert,

Ce n'est pas la MFC qui prend du temps mais la macro pour le comptage.

Pour qu'elle ne s'exécute pas chaque fois qu'on modifie une cellule utilisez une macro non évènementielle :

Sub Comptage()
'se lance par les touches Ctrl+M
Dim ncol%, a&(), col%, c As Range
ncol = 24 'nombre de colonnes, à adapter
ReDim a(1 To ncol)
For col = 1 To ncol
    For Each c In ActiveSheet.UsedRange.Columns(col).Cells
        If c <> "" Then If c.DisplayFormat.Interior.Color = vbRed Then a(col) = a(col) + 1
Next c, col
'---restitution---
[A1].Resize(, ncol) = a
Application.EnableEvents = True 'réactive les évènements
End Sub

Voyez le fichier (3) joint avec un tableau de 24 colonnes et 5005 lignes.

A+

 

[job75]

La solution de Robert est la plus rapide.

Chez moi sur le fichier de mon post précédent, sans MFC, sa macro s'exécute en 2,2 secondes.

Chez moi, avec MFC bien sûr, ma macro Comptage s'exécute en 8,8 secondes.

Mais l'intérêt de la MFC c'est que la couleur s'applique immédiatement quand on modifie des données?

Edit : en conclusion DisplayFormat teste bien les MFC mais sa lecture prend du temps.

Bonne nuit.

 

[mapomme]

Bonjour à tous,

Pour le fun, une méthode avec deux fonctions et une MFC utilisant une des deux fonctions:

La Function CarSpecial(ByVal x) As Boolean qui renvoie Vrai ou Faux suivant que le texte x contient ou non des caractères "spéciaux". Cette fonction est utilisée dans la MFC.

Function NbrCellCarSpecial(ByVal xrg As Range) As Long qui renvoie le nombre de cellules dans la plage xrg ayant au moins un caractère "spécial". Cette fonction utilise aussi la fonction CarSpecial().

La constante CaracAdmis contient les caractères admis (lettres, lettres accentuées, chiffres, espace). Tout caractère non élément de cette constante est considéré comme caractère spécial. La constante est modifiable par l'utilisateur.

De plus, une cellule contenant deux espaces consécutifs est considérée comme contenant un caractère spécial.

Il me semble que la MFC ne ralentit pas Excel (ni le comptage).

nota : personnellement, j'ai compris que les accents étaient autorisés (admis). Si ce n'est pas le cas, les retirer simplement de la constante CaracAdmis.

Le code dans module1 :

Const CaracAdmis = "abcdefghijklmnopqrstuvwxyzæœàâäçèéêëîïôöùûü0123456789 "

Function CarSpecial(ByVal x) As Boolean
Dim i&
   x = LCase(x)
   If InStr(x, "  ") > 0 Then CarSpecial = True: Exit Function    ' si deux espaces consécutifs
   For i = 1 To Len(x)
      If InStr(CaracAdmis, Mid(x, i, 1)) = 0 Then CarSpecial = True: Exit Function     'si car non admis
   Next i
End Function

Function NbrCellCarSpecial(ByVal xrg As Range) As Long
Dim x, n&
   For Each x In xrg: n = n - CarSpecial(x): Next
   NbrCellCarSpecial = n
End Function

 

[job75]

Bonjour mapomme, le fil

Bravo, en effet c'est bien simple avec une fonction VBA pour définir la MFC.

A+

 

[Rabeto]

1

Bonjour à tous,

Merci pour le temps que vous avez accordé.

J'ai aussi trouvé un autre macro que j'ai testé.

Sub Colorer()
Range("A3:C9").Select
For Each Cell In Selection
If InStr(Cell.Text, ".") Or InStr(Cell.Text, ",") Or InStr(Cell.Text, "/") Then
Cell.Interior.ColorIndex = 3
Else
Cell.Interior.ColorIndex = 0
End If
Next
Range("A3").Select
End Sub

Si je souhaite définir une plage pour les critères au lieu d'insérer un à un comme celui ci, est ce possible ?
If InStr(Cell.Text, ".") Or InStr(Cell.Text, ",") Or InStr(Cell.Text, "/") Then

 

[job75]

@Rabeto sachez que Cell.Text prend nettement plus de temps que Cell.Value.

 

[job75]

S'il n'y a que 3 critères c(est extrêmement simple par formule, pas besoin de VBA :

Formule de la MFC :

=ESTNUM(TROUVE(".";A3))+ESTNUM(TROUVE(",";A3))+ESTNUM(TROUVE("/";A3))

Formule de comptage en A1, à tirer vers la droite :

=SOMMEPROD(SIGNE(ESTNUM(TROUVE(".";A3:A9))+ESTNUM(TROUVE(",";A3:A9))+ESTNUM(TROUVE("/";A3:A9))))

 

[Rabeto]

Les 3 critères étaient juste des exemples, mais si on adapte la macro avec le fichier,
et définir la colonne H comme liste de critère.
Au lieu de saisir un à un les critères, juste dire dans la macro que les critères se trouvent dans la colonne H.

Sub Colorer()
Range("A3:C9").Select
For Each Cell In Selection
If InStr(Cell.Text, ".") Or InStr(Cell.Text, ",") Or InStr(Cell.Text, "/") Then ( à Modifier par une liste définie dans la colonne H)
Cell.Interior.ColorIndex = 3
Else
Cell.Interior.ColorIndex = 0
End If
Next
Range("A3").Select
End Sub

J'aimerai tester