Macro colorer cellule

Résolu

Loriiiis -

Bonjour à tous,
J'ai une colonne L où se trouve plusieurs nom de personnes
Je voudrais un bouton (donc macro il me semble) ou quand je clique dessus tous les Fabien (par exemple) se mettent en couleur. Et quand on reclic tout redevient normal.
Ceci est possible par la mise en forme conditionnelle mais on ne peut pas revenir à la normal sans tout refaire le processus....
Est-ce possible ?
En attente de vous lire, merci d'avance
Loris,

Afficher la suite

2 réponses

f894009

Bonjour,

un exemple:
double clic sur un prenom, toutes les cellules de ce prenom passent en vert
double clic sur le meme prenom ou double clic sur un autre prenom passage sans couleur du prenom precedent et passage en vert du prenom en cour

https://www.cjoint.com/c/FLBnZE6P0rf

Code dans VBA de le feuille

Loriiiis Auteur
c'est exactement ce que je cherchais ! Mais peut on rajouter une option ou quand on clique sur une cellule vide plus aucun prenom n'est coloré ?
Et ne m'y connaissant pas, comment rentrer ce que vous avez fait dans mon tableur et que cela fonctionne ?
0

f894009

@LoriiiisBonjour,

code a copier dans VBA de la feuille:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Count > 1 Then Exit Sub
    derlig = Range("A" & Rows.Count).End(xlUp).Row
    If Not Application.Intersect(Target, Range("A2:A" & derlig)) Is Nothing Then
        Cancel = True
        Application.ScreenUpdating = False
        Cel = Target.Value
        Range("A2:A" & derlig).Interior.Pattern = xlNone
        Nb = Application.CountIf(Columns(1), Cel)
        If Nb > 0 Then
            lig = 2 'ligne de depart

            For N = 1 To Nb
                lig = Columns(1).Find(Cel, Cells(lig, 1), , xlWhole).Row
                If Cells(lig, 1).Interior.Color = vbGreen Then
                    Cells(lig, 1).Interior.Pattern = xlNone
                Else
                    Cells(lig, 1).Interior.Color = vbGreen
                End If
            Next N
        End If
    End If
    Application.ScreenUpdating = True
End Sub

'clic droit sur cellules colonne A pour enlever couleur
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Count > 1 Then Exit Sub
    derlig = Range("A" & Rows.Count).End(xlUp).Row
    If Not Application.Intersect(Target, Range("A2:A" & derlig)) Is Nothing Then
        Cancel = True
        Range("A2:A" & derlig).Interior.Pattern = xlNone
    End If
End Sub

Pour ouvrir la fenetre VBA, appuyez sur touches alt+F11, double clic sur la feuille en haut a gauche, copier/coller le code et essayez

f894009

Re,

aperçu de la fenetre VBA avec code dans feuille

Loriiiis Auteur
Merci bien pour votre code, mais étant totalement incompétent (et je m'en excuse) en programmation, j'ai réussi à ouvrir la fenêtre via alt+F11 et puis je suis bloquer....
Je voulais également savoir si cette fonction de couleur selon le texte marche sur toute les colonnes ou uniquement sur celle souhaité (dans mon cas L) ?
0
Loriiiis Auteur
@LoriiiisAlors après recherche j'ai réussis à inserer mon code... Le probleme c'est qu'il marche pour la colonne A uniquement. Je le voudrais si possible sur la L
0

f894009

@LoriiiisBonjour,

Colonne L

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Count > 1 Then Exit Sub
    derlig = Range("L" & Rows.Count).End(xlUp).Row
    If Not Application.Intersect(Target, Range("L2:L" & derlig)) Is Nothing Then
        Cancel = True
        Application.ScreenUpdating = False
        Cel = Target.Value
        Range("L2:L" & derlig).Interior.Pattern = xlNone
        Nb = Application.CountIf(Columns(12), Cel)
        If Nb > 0 Then
            lig = 2 'ligne de depart

            For N = 1 To Nb
                lig = Columns(12).Find(Cel, Cells(lig, 12), , xlWhole).Row
                If Cells(lig, 12).Interior.Color = vbGreen Then
                    Cells(lig, 12).Interior.Pattern = xlNone
                Else
                    Cells(lig, 12).Interior.Color = vbGreen
                End If
            Next N
        End If
    End If
    Application.ScreenUpdating = True
End Sub

'clic droit sur cellules colonne A pour enlever couleur
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Count > 1 Then Exit Sub
    derlig = Range("L" & Rows.Count).End(xlUp).Row
    If Not Application.Intersect(Target, Range("L2:L" & derlig)) Is Nothing Then
        Cancel = True
        Range("L2:L" & derlig).Interior.Pattern = xlNone
    End If
End Sub

Loriiiis Auteur
@f894009Merci beaucoup d'avoir pris le temps de répondre à ce post, c'est très gentil. Toutefois si vous accepté de prendre encore quelque minutes pour compléter cette macro ce serai vraiment sympathique. je m'explique :
Tous les prénoms sont recensés (1 fois chacun) dans la colonne Q à partir de la ligne 47 jusqu’à infinis puisque je remets des prénoms tous les mois.
- Serait-il possible qu'eux se mettent également en couleur via le double clic ? (En synchronisation avec la colonne L)
- Peut-on ajouter une option où aucune cellule n'est coloré (double clic dans la colonne N par exemple)
J'insiste sur le fais que vous m'avez déjà bien aidé (je vous en remercie encore) et que je comprendrais que vous n'ayez pas envie de résoudre ces 2 petits soucis qu'il me reste.
Bien cordialement,
0

f894009

@LoriiiisBonjour,

Ok, mais
- Peut-on ajouter une option où aucune cellule n'est coloré (double clic dans la colonne N par exemple)
Vous avez deja le clic droit sur colonne L!!!!!!!!!!!!!!!!

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Count > 1 Then Exit Sub
    derlig = Range("L" & Rows.Count).End(xlUp).Row
    If Not Application.Intersect(Target, Range("L2:L" & derlig)) Is Nothing Then
        Cancel = True
        Application.ScreenUpdating = False
        Cel = Target.Value
        Range("L2:L" & derlig).Interior.Pattern = xlNone
        Nb = Application.CountIf(Columns(12), Cel)
        If Nb > 0 Then
            lig = 2 'ligne de depart
            For N = 1 To Nb
                lig = Columns(12).Find(Cel, Cells(lig, 12), , xlWhole).Row
                If Cells(lig, 12).Interior.Color = vbGreen Then
                    Cells(lig, 12).Interior.Pattern = xlNone
                Else
                    Cells(lig, 12).Interior.Color = vbGreen
                End If
            Next N
        End If
        derlig = Range("Q" & Rows.Count).End(xlUp).Row
        Range("Q47:Q" & derlig).Interior.Pattern = xlNone
        Nb = Application.CountIf(Columns(17), Cel)
        If Nb > 0 Then
            lig = 47 'ligne de depart
            For N = 1 To Nb
                lig = Columns(17).Find(Cel, Cells(lig, 17), , xlWhole).Row
                If Cells(lig, 17).Interior.Color = vbGreen Then
                    Cells(lig, 17).Interior.Pattern = xlNone
                Else
                    Cells(lig, 17).Interior.Color = vbGreen
                End If
            Next N
        End If
    End If
    Application.ScreenUpdating = True
End Sub

'clic droit sur cellules colonne Q et L pour enlever couleur
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Count > 1 Then Exit Sub
    derligL = Range("L" & Rows.Count).End(xlUp).Row
    derligQ = Range("Q" & Rows.Count).End(xlUp).Row
    If Not Application.Intersect(Target, Range("L2:L" & derlig)) Is Nothing Then
        Cancel = True
        Range("L2:L" & derligL).Interior.Pattern = xlNone
        Range("Q47:Q" & derligQ).Interior.Pattern = xlNone
    End If
End Sub

Macro colorer cellule

2 réponses

Discussions similaires

Newsletters