Autres Colorer une cellule en un clic

baguihome

XLDnaute Nouveau
Bonjour à tous,

J'ai crée un fichier excel dans lequel je souhaiterai rendre une colonne interactive : pour chacune des cellules de cette colonne, un clic = colore la cellule en rouge ; un deuxième clic dans cette même cellule = colore en vert (passe du rouge au vert) ; un troisième clic = retour à la couleur initiale de la cellule (passe du vert à la couleur initiale de la cellule).
J'ai trouvé un code qui fonctionne assez bien (je le mets en fin de post). Reste quelques petits problèmes : le 3ème clic colore la cellule en blanc alors que les lignes de mon fichier sont alternativement blanches et grises. C'est pour ça que je souhaiterais pouvoir ramener la cellule à sa couleur d'origine au 3ème clic. Deuxième petit problème, quand j'essaie de protéger le reste du fichier (toutes les cellules sauf celle de la colonne colorable) la macro ne fonctionne plus. 3ème problème, le code que j'ai trouvé s'applique sur 2 colonnes, quelles modifications apporter au code pour qu'il ne concerne plus que la colonne D. Enfin, le code suivant fonctionne avec un double clic, je souhaiterai qu'il fonctionne avec un clic gauche.

Est-ce faisable de faire ce que je souhaite ?

Merci d'avance pour votre aide et désolé pour mon ignorance…:rolleyes:☺️

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim couleurs()
If Not Intersect(Target, Range("D:E")) Is Nothing Then
couleurs = Array(RGB(255, 0, 0), RGB(13, 241, 105), RGB(255, 255, 255))
On Error GoTo color
Target.Interior.color = couleurs(Application.WorksheetFunction.Match(Target.Interior.color, couleurs, 0) Mod 3)
Cancel = True
End If
Exit Sub
color:
Target.Interior.color = couleurs(0)
Cancel = True
End Sub
 

bsalv

XLDnaute Occasionnel
re,
Code:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

     Dim Couleurs(): Couleurs = Array(-1, RGB(255, 0, 0), RGB(13, 241, 105))

     If Intersect(Target, Range("D:E")) Is Nothing Then Exit Sub

     With Target
          Me.Unprotect
          ic = .Interior.color
          i = Application.Match(ic, Couleurs, 0)
          If Not IsNumeric(i) Then
               i = 1     'on prendra "rouge"
               On Error Resume Next
               s = "?": s = .Comment.Text     'y-a-t-il déjà du commentaire dans la cellule, sinon s sera "?"
               On Error GoTo 0
               If s = "?" Then .AddComment: .Comment.Visible = False     'créer commentaire invisible
               .Comment.Text Text:=CStr(ic)     'ajouter numéro du couleur dans le commentaire
          End If

          Select Case (i Mod 3)
               Case 1, 2: Target.Interior.color = Couleurs(i Mod 3)     'seulement votre rouge et vert
               Case Else
                    On Error Resume Next
                    .Interior.color = xlNone     'aucun couleur
                    .Interior.color = .Comment.Text     'essayer à mettre la couleur di commentaire
                    On Error GoTo 0
          End Select
          Cancel = True
          Me.Protect
     End With

End Sub
 

baguihome

XLDnaute Nouveau
Bonjour Bsalv,

Merci beaucoup pour ton code, il fonctionne à merveille !! Si je comprend bien tu as utilisé un commentaire comportant le code couleur initial de la cellule ? Juste une petite question, peut-on transformer le double clic en simple clic ?

En tout cas merci beaucoup, c'est top !!
 

bsalv

XLDnaute Occasionnel
bonjour bagouihome,

Oui, le couleur initial est dans le commentaire, c'était le plus facile à réaliser, mais il y a d'autres méthodes, si vous utilisez déjà les commentaires ... .

Si vous changez le nom de la macro "Worksheet_BeforeDoubleClick" en "Worksheet_BeforeRightClick" cela fonctionnera avec le bouton droit.
 

baguihome

XLDnaute Nouveau
J'ai essayé de remplacer "Worksheet_BeforeDoubleClick" par "Worksheet_SelectionChange" mais ça ne fonctionne pas. Ca ne fonctionne pas non plus avec "Worksheet_BeforeRightClick". J'ai l'impression que c'est la protection de la feuille qui pose probleme...?
 

Discussions similaires

Réponses
0
Affichages
83

Statistiques des forums

Discussions
311 711
Messages
2 081 792
Membres
101 817
dernier inscrit
carvajal