Compter les lignes de couleurs
Bonsoir,
avec office 365 n'y a t il pas .DisplayFormat.Interior.Color , qui permet de connaitre la couleur d'une cellule suite à une MFC.
@ bientôt
LouReeD
Bonsoir,
un essai avec le premier fichier où apparemment il n'y a pas de bleu foncé :
Le code :
Sub testLRD()
Dim DerLigne As Long, C(1 To 3) As Long, Cpt(1 To 3) As Long, Coul As Long, I, J
For I = 1 To 3
C(I) = Range("S" & I).Interior.Color
Next I
DerLigne = Range("A" & Rows.Count).End(xlUp).Row
For I = 6 To DerLigne
DoEvents
Coul = Range("B" & I).DisplayFormat.Interior.Color
If Coul <> xlNone Then
For J = 1 To 3
If Coul = C(J) Then Cpt(J) = Cpt(J) + 1: Exit For
Next J
End If
Next I
For I = 1 To 3
Cells(I, 20) = Cpt(I)
Next I
End Sub@ bientôt
LouReeD
Bonsoir louReed,
Oui un code a été fait avec cette fonction.
Sub exemple()
Dim i As Integer, compt1 As Integer, derli As Integer, nbli As Integer, comp2 As Integer, compt3 As Integer, compt4 As Integer, compt5 As Integer
derli = Cells(Rows.Count, 1).End(xlUp).Row
Dim tableau()
ReDim tableau(derli - 2, 11)
nbli = derli - 6
compt1 = 0
compt2 = 0
compt3 = 0
compt4 = 0
compt5 = 0
Application.Calculation = xlCalculationManuel 'stopper les calculs
Application.ScreenUpdating = False 'stopper le rafraichissement de l'écran
i = 0
For i = 0 To derli - 2
tableau(i, 11) = Range("L" & i + 6).DisplayFormat.Interior.Color
If tableau(i, 11) = 16247773 Then
compt1 = compt1 + 1
ElseIf tableau(i, 11) = 15123099 Then
compt2 = compt2 + 1
ElseIf tableau(i, 11) = 11892015 Then
compt3 = compt3 + 1
ElseIf tableau(i, 11) = 13431551 Then
compt4 = compt4 + 1
ElseIf tableau(i, 11) = 11854022 Then
compt5 = compt5 + 1
End If
Next
Range("T1") = compt1 / nbli
Range("T2") = compt2 / nbli
Range("T3") = compt3 / nbli
Range("T4") = compt4 / nbli
Range("T5") = compt5 / nbli
Application.Calculation = xlCalculationAutomatic 'réactiver les calculs
Application.ScreenUpdating = True 'réactiver le rafraichissement de l'écran
End Subjuste le jour où l'on désire changer les couleurs, il faut retrouver leur valeur en "long" dans le code...
Si 5 compteurs alors un tableau(5) permet de simplifier.
pourquoi ceci ReDim tableau(derli - 2, 11) ?
@ bientôt
LouReeD
Bonjour à tous, et merci à tous pour vos contributions LouReeD, voici ce que ça donne avec ton code, ça fonctionne très bien sur mon fichier original est il possible de me rajouter le comptage des lignes jaune et verte stp, merci beaucoup.
Bonjour,
Sur le code de LouReed j'ai fait une petite modification pour englober les deux autres couleurs. Essayez ce code sur votre fichier pour voir.
Sub testLRD()
Dim DerLigne As Long, C(1 To 5) As Long, Cpt(1 To 5) As Long, Coul As Long, I, J
For I = 1 To 5
C(I) = Range("S" & I).Interior.Color
Next I
DerLigne = Range("A" & Rows.Count).End(xlUp).Row
For I = 6 To DerLigne
DoEvents
Coul = Range("N" & I).DisplayFormat.Interior.Color
If Coul <> xlNone Then
For J = 1 To 5
If Coul = C(J) Then Cpt(J) = Cpt(J) + 1: Exit For
Next J
End If
Next I
For I = 1 To 5
Cells(I, 20) = Cpt(I)
Next I
End SubBonjour LouReed,
Pour mon code le ReDim tableau(derli - 2, 11) j'ai suivi le cours VBA sur les tableaux qui précise qu'il y a lieu de dimentionner les tableau lorsqu'on déclare un TCD . Dim tableau() sans rien dans les parenthèses représente un TCD.
Déclarez un tableau dynamique (parenthèses vides), puis définissez ses dimensions avec Redim :
Dim tableau()
ReDim tableau(derniereLigne - 2, 2)
De cette manière vous enregistrerez automatiquement toutes les lignes de la base de données dans le tableau :Pour ce qui concerne les couleurs des cellules de la colonne S dans le premier fichier fourni elles ne correspondaient pas à celles des règles MFC. Je les ai modifiées et avec les fonctions complémentaires on peut remplir la colonne T simplement avec des formules. Le traitement des données est un peu long.
Bonjour à tous,
@fcyspm30:
Dans cette partie de code il faudrait remplacer tb(i,11) par tb(i,10).
Non, en fait j'ai trouvé mon erreur : j'ai mis >0 pour la dernière condition alors que c'était =0
And (tb(i, 12) + tb(i, 13) + tb(i, 14)) > 0En revanche, je ne m'explique pas pourquoi mon résultat pour "pas venu depuis 3 derniers mois" n'est pas correct....
Sur ma première proposition, tout comme toi, je trouvait bien 16%, alors qu'ici le résultat est 20%.....je dois loupé quelque chose....frustrant..
C'est dommage, car le traitement semblait plutôt rapide.
Option Explicit
Dim tb, cpt1&, cpt2&, cpt3&, cpt4&, cpt5&
Dim val&, z&, nul%
Dim i&, nblig&, x%, y%
Sub test()
tb = Range("A6:Q" & Range("A" & Rows.Count).End(xlUp).Row) '...............Tableau de valeurs
Range("T1:T5").ClearContents: Range("T1:T5").NumberFormat = "0%"
nblig = UBound(tb, 1) - 1 '................................................nombre de ligne moins ligne de totaux
Application.ScreenUpdating = False
For i = 1 To UBound(tb, 1) '................................................Boucle sur les lignes du tableau de valeurs
val = 0: z = 0: nul = 0
For x = 2 To 15 '.......................................................boucle sur les colonnes (de B à O)
If tb(i, x) <> "" Then val = val + 1 '.................................nombre de valeurs
If tb(i, x) = 0 Then z = z + 1 '.......................................nombre de zéros
Next x
For y = 12 To 15
If IsEmpty(tb(i, y)) Then nul = nul + 1 '..............................nombre ce cellules vides de L à O
Next y
'***********************************************************************************************************
'=ET(NB($B6:$O6)=5;NB.SI($B6:$O6;"=0")=0)
If val = 5 And z <> 0 Then
cpt1 = cpt1 + 1 '....................................................4 mois remplis
End If
'***********************************************************************************************************
'=ET(NB($B6:$O6)=7;NB.SI($B6:$O6;"=0")=0)
If val = 7 And z <> 0 Then
cpt2 = cpt2 + 1 '....................................................6 mois remplis
End If
'***********************************************************************************************************
'=ET(NB($B6:$O6)=13;NB.SI($B6:$O6;"=0")=0)
If val = 13 And z <> 0 Then
cpt3 = cpt3 + 1 '....................................................12 mois remplis
End If
'**********************************************************************************************************
'=NBVAL($L6:$O6)=0
If nul = 4 Then
'If IsEmpty(tb(i, 12)) And IsEmpty(tb(i, 13)) And IsEmpty(tb(i, 14)) And IsEmpty(tb(i, 15)) Then
'If tb(i, 12) = "" And tb(i, 13) = "" And tb(i, 14) = "" And tb(i, 15) = "" Then
cpt4 = cpt4 + 1 '.....................................................pas venu depuis 3 derniers mois
End If '===> résultat FAUX ??
'**********************************************************************************************************
'=ET(SOMME($B6:$D6)>0;SOMME($E6:$G6)>0;SOMME($H6:$J6)>0;$K6>=7;SOMME($L6:$N6)=0)
If Application.Sum(tb(i, 2), tb(i, 3), tb(i, 4)) > 0 _
And Application.Sum(tb(i, 5), tb(i, 6), tb(i, 7)) > 0 _
And Application.Sum(tb(i, 8), tb(i, 9), tb(i, 10)) > 0 _
And tb(i, 11) >= 7 _
And Application.Sum(tb(i, 12), tb(i, 13), tb(i, 14)) = 0 Then
cpt5 = cpt5 + 1 '......................................................patient à rappeler
End If
Next i
'***********************************************************************************************************
Range("T1") = cpt1 / nblig: cpt1 = 0 'ok
Range("T2") = cpt2 / nblig: cpt2 = 0 'ok
Range("T3") = cpt3 / nblig: cpt3 = 0 'ok
Range("T4") = cpt4 / nblig: cpt4 = 0 'faux ?
Range("T5") = cpt5 / nblig: cpt5 = 0 'ok
Erase tb
End Sub@Brunotahiti : petite différence avec mes camarades, mon code ne tient pas compte des couleurs, mais des conditions de tes MFC.
Je ne prends en compte que les valeurs.
Cordialement,
Bonjour Fcyspm30,
C'est parfait ! ça fonctionne avec toutes les couleurs ;)
Merci beaucoup et à bientôt,
Bruno
Hello Xorsankukai,
Merci pour ton code sur les conditions de mes MFC je teste tout à l'heure
A bientôt,Bruno
Bonjour,
Si ça fonctionne c'est parfait mais attention il ne faut pas modifier les couleurs dans les MFC anisi que dans le petit tableau car s'il y a une différence ça les calculs seront erronés.
Bonjour, ok merci c’est bien noté.
Maintenant je cherche à récupérer les noms de patients face à la couleur verte (les patients que je dois rappeler) savez-vous comment je peux extraire cette liste svp ? Merci et bonne journée
Bonjour,
J'ai rajouté quelques lignes au code de LouReeD mais je ne peux pas tester car il n'y a pas de vert sur mon fichier. Les patients à rappeler devraient .... s'inscrire en colonne V mais je ne suis vraiment pas sûr de moi.
Sub testLRD()
Dim DerLigne As Long, C(1 To 5) As Long, Cpt(1 To 5) As Long, Coul As Long, I, J, k
For I = 1 To 5
C(I) = Range("S" & I).Interior.Color
Next I
DerLigne = Range("A" & Rows.Count).End(xlUp).Row
For I = 6 To DerLigne
DoEvents
Coul = Range("N" & I).DisplayFormat.Interior.Color
If Coul <> xlNone Then
For J = 1 To 5
If Coul = C(J) Then Cpt(J) = Cpt(J) + 1: Exit For
Next J
End If
If J = 5 Then
For k = 2 To DerLigne
Range("V" & k) = Range("A" & I)
Next
End If
Next I
For I = 1 To 5
Cells(I, 20) = Cpt(I)
Next I
End SubBonjour à tous,
je cherche à récupérer les noms de patients face à la couleur verte (les patients que je dois rappeler)
Une variante sur le même principe que précédemment....
Le code est à placer dans le module de la feuille "Patients à rappeler (à créer) et s'exécute à l'activation de cette dernière.
Private Sub Worksheet_Activate()
Dim tb, val(), k&, i&
Range("A1").CurrentRegion.Offset(1, 0).ClearContents
tb = Sheets("TCD").Range("A6:Q" & Sheets("TCD").Range("A" & Rows.Count).End(xlUp).Row)
k = 0
ReDim val(0 To UBound(tb, 1), 1 To 1)
For i = 1 To UBound(tb, 1)
If Application.Sum(tb(i, 2), tb(i, 3), tb(i, 4)) > 0 _
And Application.Sum(tb(i, 5), tb(i, 6), tb(i, 7)) > 0 _
And Application.Sum(tb(i, 8), tb(i, 9), tb(i, 10)) > 0 _
And tb(i, 11) >= 7 _
And Application.Sum(tb(i, 12), tb(i, 13), tb(i, 14)) = 0 Then
val(k, 1) = tb(i, 1)
k = k + 1
End If
Next i
If k > 0 Then
Range("A2").Resize(k, 1).Value = val
End If
End SubTout comme le suggère fcyspm30, on peut l'intégrer dans la macro de comptage....
Cordialement,
C'est bien ce que je pensais, mes lignes rajoutées ne collent pas du tout.
Rebonjour,
J'ai effectué ce code avec une autre couleur et ça fonctionne.
Sub testLRD()
Dim DerLigne As Long, C(1 To 5) As Long, Cpt(1 To 5) As Long, Coul As Long, I, J, k
For I = 1 To 5
C(I) = Range("S" & I).Interior.Color
Next I
DerLigne = Range("A" & Rows.Count).End(xlUp).Row
Dim tableau(1000000)
Range("V6:V1000000") = ""
k = 6
For I = 6 To DerLigne
tableau(I) = Range("A" & I)
Coul = Range("N" & I).DisplayFormat.Interior.Color
If Coul <> xlNone Then
For J = 1 To 5
If Coul = C(J) Then Cpt(J) = Cpt(J) + 1: Exit For
Next J
End If
If Coul = Range("S5").Interior.Color Then
Range("V" & k) = tableau(I)
k = k + 1
End If
Next I
For I = 1 To 5
Cells(I, 20) = Cpt(I)
Next I
End SubBonsoir,
fcyspm30, vous utilisez un tableau() pour inscrire le nom des patients en fonction d'une couleur, mais votre code ne correspond pas à cela, vous pourriez dans votre cas ne mettre qu'une variable "String" voir même pas de variable :
If Coul = Range("S5").Interior.Color Then
Range("V" & k) = Range("A" & I)
k = k + 1
End Ifne vous y trompez pas, je ne critique pas c'est juste pour optimiser. L'idée du tableau est bonne afin de ne pas augmenter les accès feuille comme cela en fin de boucle de I, on inscrit le résultat du tableau en une fois, le code serait donc plus celui-ci :
Sub testLRD()
Dim DerLigne As Long, C(1 To 5) As Long, Cpt(1 To 5) As Long, Coul As Long, I, J, K
Dim Tableau()
' récupération des couleurs de base
For I = 1 To 5
C(I) = Range("S" & I).Interior.Color
Next I
' détermination de la dernière ligne
DerLigne = Range("A" & Rows.Count).End(xlUp).Row
' on efface les noms des patients
Range("V6:V" & Range("V" & Rows.Count).End(xlUp).Row) = ""
' initialisation de l'index du tableau de sortie
K = 0
' boucle sur les lignes "patients"
For I = 6 To DerLigne
' on récupère la couleur de la ligne testée
Coul = Range("N" & I).DisplayFormat.Interior.Color
' si la couleur est autre chose que le fond transparent
If Coul <> xlNone Then
' on boucle sur la tableau de couleur de base
For J = 1 To 5
' si la couleur de la ligne correspond à la couleur testée du tableau de couleur de base
' on incrémente le compteur de cette couleur dans le tableau de couleur
If Coul = C(J) Then Cpt(J) = Cpt(J) + 1: Exit For
Next J
End If
' si la couleur correspond à la couleur des patients "à rappeler"
If Coul = C(5) Then
' on redimensionne en préservant les données le tableau de sortie de 1 index
' afin d'y inscrire le nom du patient
ReDim Preserve Tableau(K + 1)
Tableau(K) = Range("A" & I)
' on a inscrit une donnée, on incrémente l'index du tableau pour la donnée suivante éventuelle
K = K + 1
End If
Next I
' on inscrit les données de sortie
' le nombre de chaque couleur
For I = 1 To 5
Cells(I, 20) = Cpt(I)
Next I
' le noms des patients à partir de la cellule V6
Range("V6").Resize(UBound(Tableau)) = Application.Transpose(Tableau)
End SubLe REDIM PRESERVE évite de dimensionner des tableaux sur un nombre d'index inutiles. Le RESIZE permet de redimensionner une cellule ou une plage : ici on part de la cellule seule V6 que l'on redimensionne en nombre de ligne correspondant au nombre d'index de notre variable tableau. Application.Transpose permet le collage en verticale du tableau.
@ bientôt
LouReeD
Merci LooReeD pour toutes ces explications. Je suis preneur à 100% car je m'initie au VBA et je n'en suis qu'à mon début. Aussi aucune hésitation pour me reprendre sur mes erreurs, c'est comme cela que j'apprendrai surtout avec les commentaires explicatifs. Et puis j'ai 72 ans et donc des neurones qui auraient tendance à se destructurer.
Bonjour,
LouReeD j'ai testé le code et il bug sur la dernière ligne. Je ne comprends pas la fonction Application.Transpose. N'est-elle pas utilisée pour inverser lignes/colonnes? Je n'arrive pas à trouver le problème
Bonjour à tous,
LouReeD j'ai testé le code et il bug sur la dernière ligne
Peut-être ainsi:
Resize (RowSize, ColumnSize)
Range("V6").Resize(UBound(Tableau),1) = Application.Transpose(Tableau)Pour info, la fonction transpose est limitée, j'en ai fait l'expérience récemment....apparemment 65000 lignes.....
https://forum.excel-pratique.com/excel/limitation-application-transpose-124094 (voir code de h2so4)
@Bruno : As-tu testé ma proposition ? Les résultats sont-ils corrects ? (Juste histoire de confirmer qu'elle est viable,
Cordialement,