Autres Mise en couleur de cellules si précence d'un d'un commentaire précis sur la même ligne

Chrige

XLDnaute Occasionnel
Bonjour à tous
Je souhaiterais mettre en couleur des cellules suivant la présence ou pas d'un mot dans des commentaires sur la même ligne
J'ai essayé toute ma matinée, je viens donc à l'aide
Pour plus de clarté j'ai réalisé un petit exemple de mon fichier bien trop gros pour être posté.

Quelques explications :
Le mot recherché est en F1
Les cellules à mettre en vert (par exemple) sont ceux des colonnes C et D
Les cellules contenant les commentaires se trouve dans les colonnes J à V.

Je ce que je souhaite réalisé concrètement, c'est mettre en vert les cellules C4 et D4 si dans les cellules le mot placé en F1 se trouve dans les commentaires des cellules dans la plage J4 à V4, ceci à partir de la ligne 4 et jusqu'à la fin de mon fichier. Sinon mettre en gris C4 et D4.

Il faut que le mot recherché soit de préférence exactement le même. ex "jean" ne soit pas reconu dans "jeanjean"
Merci par avance
 

Pièces jointes

  • Fichier exemple.xlsm
    12.8 KB · Affichages: 19

Chrige

XLDnaute Occasionnel
Bonjour Sylvanu, Job75 et tout le Forum

Merci beaucoup pour cette macro
C'est tout à fait ce que je souhaitais
Et elle fonctionne très bien
Le seul hic, c'est le temps de traitement !!
Près de 2mn !
C'est bien long devant un écran à ne rien faire
Je m'y attendais un peu

Je ne sais pas si c'est stupide
Mais dans mes colonnes de J à V, il y a plus de cellules vide ou sans commentaires que de cellules avec des commentaires
Est-ce qu'il serait crédible de faire un test pour exclure toutes les cellules sans commentaires ??
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour,
Oui en modifiant un petit peu le IF :
Code:
 If Chaine <> "" Then
                    Chaine = Cells(L, C).NoteText
                    If " " & Chaine & " " Like "* " & Nom & " *" = True Then
                        Flag = 1: Exit For
                    End If
              End If
De cette façon si la cellule est vide on ne regarde pas le commentaire.
Mais ça suppose qu'une cellule vide n'a pas de commentaire.
 

Pièces jointes

  • Fichier exemple (V5).xlsm
    22 KB · Affichages: 3

job75

XLDnaute Barbatruc
Voyez le fichier joint et la macro du bouton :
VB:
Option Compare Text 'la casse est ignorée, mettre en commentaire pour qu'elle soit respectée

Sub Couleurs()
Dim nom$, c As Range, chaine$
nom = [F1]
Application.ScreenUpdating = False
Range("C2:D" & Rows.Count).Interior.Color = RGB(192, 192, 192) 'gris
Range("J2:V" & Rows.Count).Interior.Color = vbYellow 'jaune
For Each c In [J:V].SpecialCells(xlCellTypeComments)
    chaine = c.NoteText
    If InStr(" " & chaine & " ", " " & nom & " ") Or _
        InStr(vbLf & chaine & vbLf, vbLf & nom & vbLf) Then _
            Cells(c.Row, 3).Resize(, 2).Interior.Color = vbGreen 'vert
Next
Rows(ActiveSheet.UsedRange.Rows.Count + 1 & ":" & Rows.Count).Interior.ColorIndex = xlNone 'RAZ en dessous
End Sub
On teste pour savoir si le nom est encadré par des espaces ou par des renvois à la ligne.

Cette manière de faire n'est pas forcément la plus rapide.

A+
 

Pièces jointes

  • Fichier exemple(1).xlsm
    20.1 KB · Affichages: 2

Chrige

XLDnaute Occasionnel
Bonsoir Job75

Chez moi 20 secondes dans mon fichier de plus de 2000 lignes, c’est fulgurant !!!

Par contre j’ai plusieurs problèmes

1er problème
Ce n’est pas toutes les cellules de la colonne C et D qui doivent revenir en gris
Mais seulement celles ou il y a des cellules avec commentaires (J :V)
Car j’ai des cellules avec d’autres couleurs dans ces 2 colonnes

2ème problème
J’ai souhaité rajouter d’autres actions (Attributs supplémentaires)
(Voir la macro modifiée)
Mais si je rajoute ces actions supplémentaires, elles se réalisent sur toutes les lignes où il y a des commentaires et non pas sur celles en rapport avec le nom !!

Comme pour la remise en gris, ces attributs supplémentaires doivent revenir à la normale en cas de changement de nom en F1
 

Pièces jointes

  • Fichier exemple(5).xlsm
    720.8 KB · Affichages: 2

job75

XLDnaute Barbatruc
Chez moi 20 secondes dans mon fichier de plus de 2000 lignes, c’est fulgurant !!!
Votre ordi se traîne mais vous n'avez pas répondu aux questions de mes posts #23 et #24 !!!

Pour le 1er problème voyez les fichiers (2) joints et cette macro :
VB:
Option Compare Text 'la casse est ignorée, mettre en commentaire pour qu'elle soit respectée

Sub Couleurs()
Dim nom$, r As Range, chaine$
nom = [F1]
Application.ScreenUpdating = False
With Range("J2:V" & Rows.Count)
    .Interior.Color = vbYellow 'jaune
    Set r = .SpecialCells(xlCellTypeComments)
End With
Intersect(Range("C2:D" & Rows.Count), r.EntireRow).Interior.Color = RGB(192, 192, 192) 'gris
For Each r In r
    chaine = r.NoteText
    If InStr(" " & chaine & " ", " " & nom & " ") Or _
        InStr(vbLf & chaine & vbLf, vbLf & nom & vbLf) Then _
            Cells(r.Row, 3).Resize(, 2).Interior.Color = vbGreen 'vert
Next
Rows(ActiveSheet.UsedRange.Rows.Count + 1 & ":" & Rows.Count).Interior.ColorIndex = xlNone 'RAZ en dessous
End Sub
Chez moi sur 5200 lignes elle s'exécute en 0,7 seconde !!!

Pour le 2ème problème c'est un autre sujet, ouvrez une nouvelle discussion.
 

Pièces jointes

  • Fichier exemple(2).xlsm
    23.3 KB · Affichages: 3
  • Fichier exemple(2) - Copie.xlsm
    857.5 KB · Affichages: 3

Chrige

XLDnaute Occasionnel
Bonjour Job75 et tout le Forum



Merci à nouveau pour votre aide



En réponse à vos 2 questions :

- J’ai actuellement 1784 commentaires dans mes colonnes (J :V)

Et mon fichier a en tout 2025 lignes

- Le temps de traitement sur votre fichier (post21) est de 6.23 secondes



Oui le micro ou j’utilise ce fichier se traine !!





Je pense que j’ai trouvé la solution à ma 2ème question
Vous me direz si mon code est cohérent ?
En tout cas cela fonctionne bien



Pour le rétablissement de mes cellules en l’état habituel
Je suis obligé de le faire en 2 fois
Je ne sais pas si on peut faire mieux et plus rapide ?


VB:
Intersect(Range("C2:D" & Rows.Count), r.EntireRow).Interior.Color = RGB(192, 192, 192)

With Intersect(Range("B2:B" & Rows.Count), r.EntireRow)
    .Font.FontStyle = "Normal"
    .Font.Size = 10
    .Interior.Pattern = xlSolid
End With
 

Pièces jointes

  • Fichier exemple(8).xlsm
    36.1 KB · Affichages: 2

Discussions similaires

Réponses
2
Affichages
113

Statistiques des forums

Discussions
311 730
Messages
2 081 989
Membres
101 856
dernier inscrit
Marina40