XL 2016 Compter les cellules avec des critères

Rabeto

XLDnaute Occasionnel
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,
 

Pièces jointes

  • critère.xlsx
    9.1 KB · Affichages: 8
Solution
Bonsoir Robert,

Il vaut mieux créer la MFC et utiliser VBA pour faire le comptage en A1 B1 C1 :
VB:
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+

job75

XLDnaute Barbatruc
Bonjour Rabeto,

Je n'ai été capable que de construire la MFC sur A3:C9 :
Code:
=SOMME(-ESTNA(EQUIV(STXT(A3;LIGNE(INDIRECT("1:"&NBCAR(A3)));1);Liste;0)))
La plage H2:H38 étant nommée Liste.

A+
 

Pièces jointes

  • critère(1).xlsx
    11.9 KB · Affichages: 6

Robert

XLDnaute Barbatruc
Repose en paix
Bonsoir le fil, bonsoir le forum,

Une proposition VBA avec le code ci-desous :

VB:
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

XLDnaute Barbatruc
Bonsoir Robert,

Il vaut mieux créer la MFC et utiliser VBA pour faire le comptage en A1 B1 C1 :
VB:
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+
 

Pièces jointes

  • critère vba(1).xlsm
    18.6 KB · Affichages: 5

job75

XLDnaute Barbatruc
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 :
VB:
=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+
 

Pièces jointes

  • critère vba(2).xlsm
    18.9 KB · Affichages: 6

Rabeto

XLDnaute Occasionnel
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

XLDnaute Barbatruc
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 :
VB:
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+
 

Pièces jointes

  • critère vba(3).xlsm
    410.7 KB · Affichages: 6

job75

XLDnaute Barbatruc
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.
 
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
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 :
VB:
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
 

Pièces jointes

  • Rabeto- carspecial- v1.xlsm
    436.2 KB · Affichages: 5
Dernière édition:

Rabeto

XLDnaute Occasionnel
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
 

Pièces jointes

  • critère(1).xlsx
    11.6 KB · Affichages: 4

job75

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

Formule de la MFC :
Code:
=ESTNUM(TROUVE(".";A3))+ESTNUM(TROUVE(",";A3))+ESTNUM(TROUVE("/";A3))
Formule de comptage en A1, à tirer vers la droite :
Code:
=SOMMEPROD(SIGNE(ESTNUM(TROUVE(".";A3:A9))+ESTNUM(TROUVE(",";A3:A9))+ESTNUM(TROUVE("/";A3:A9))))
 

Pièces jointes

  • critère(1).xlsx
    10.5 KB · Affichages: 4

Rabeto

XLDnaute Occasionnel
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
 

Pièces jointes

  • CRITERE.xlsm
    18.7 KB · Affichages: 2

Discussions similaires

Statistiques des forums

Discussions
311 716
Messages
2 081 848
Membres
101 826
dernier inscrit
dododu89