Couleur de Cellule en fonction d'une sélection

[orion2000]

Bonjour,

J'aurai voulu savoir comment colorer des cellules en fonction des case que l'on a sélectioné.
Exemple: si je sélectionne la cellule A1 je veux que le fond des cellules b5,c13 et e7 deviennent rouge, mais à partir du moment ou je sélectionne une autre cellule cette couleur disparait.

Je pense que le VBA s'impose et pour le moment j'ai essayer ça:

Sub couleurs()
If Not Intersect(ActiveCell, Range("B5")) Is Nothing Then
Cells("B15").Interior.ColorIndex = 46
End If
End Sub

mais ça ne fonctionne pas.

Merci.

 

[Guest]

Re : Couleur de Cellule en fonction d'une sélection

Bonjour et bienvenue sur le forum,

Click-droit sur l'onglet de la feuille (en bas) puis "Visualiser le code"

Coller les lignes ci-dessous dans la fenêtre de l'éditeur de code.
Où ou 3 est l'index du rouge dans la palette de couleur par défaut.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Address(0, 0) = "A1" Then
        Range("B5,C13,E7").Interior.ColorIndex = 3
    Else
        Range("B5,C13,E7").Interior.ColorIndex = xlNone
    End If
End Sub

A+

 

[BOISGONTIER]

Re : Couleur de Cellule en fonction d'une sélection

Bonjour,

http://boisgontierjacques.free.fr/fichiers/jb-Curseur.xls

JB

 

[orion2000]

Re : Couleur de Cellule en fonction d'une sélection

Ca marche nikel merci bcp pour la pertinence et la rapidité de réponse

A+

 

[orion2000]

Re : Couleur de Cellule en fonction d'une sélection

Re bonjour j'ai rencontré un nouveau soucis les ligne de code marche bien, mais elles empeche une macro de fonctionner correctement. voici ce qu'il y a dans ma feuille

Sub Macro2()
'
' Macro2 Macro
' Macro enregistrée le 09/11/2011 par Jul
'

'
Range("K416").Select
Selection.Copy
Range("Q4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("Q5:V16").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("V5"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("E11").Select
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Range("k3") = 1 Then
Macro2
Else
Exit Sub
End If
End Sub



Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address(0, 0) = "B7" Or Target.Address(0, 0) = "B8" Then
Range("A12").Interior.ColorIndex = 48
Else
Range("A12").Interior.ColorIndex = 2
End If

If Target.Address(0, 0) = "E7" Or Target.Address(0, 0) = "E8" Then
Range("A13").Interior.ColorIndex = 48
Else
Range("A13").Interior.ColorIndex = 2
End If


If Target.Address(0, 0) = "H7" Or Target.Address(0, 0) = "H8" Then
Range("A14").Interior.ColorIndex = 48
Else
Range("A14").Interior.ColorIndex = 2
End If


If Target.Address(0, 0) = "B5" Or Target.Address(0, 0) = "B6" Then
Range("A15").Interior.ColorIndex = 48
Else
Range("A15").Interior.ColorIndex = 2
End If

If Target.Address(0, 0) = "E5" Or Target.Address(0, 0) = "E6" Then
Range("A16").Interior.ColorIndex = 48
Else
Range("A16").Interior.ColorIndex = 2
End If

If Target.Address(0, 0) = "H5" Or Target.Address(0, 0) = "H6" Then
Range("A17").Interior.ColorIndex = 48
Else
Range("A17").Interior.ColorIndex = 2
End If

If Target.Address(0, 0) = "B6" Or Target.Address(0, 0) = "B8" Then
Range("A18").Interior.ColorIndex = 48
Else
Range("A18").Interior.ColorIndex = 2
End If


If Target.Address(0, 0) = "E6" Or Target.Address(0, 0) = "E8" Then
Range("A19").Interior.ColorIndex = 48
Else
Range("A19").Interior.ColorIndex = 2
End If

If Target.Address(0, 0) = "H6" Or Target.Address(0, 0) = "H8" Then
Range("A20").Interior.ColorIndex = 48
Else
Range("A20").Interior.ColorIndex = 2
End If

If Target.Address(0, 0) = "B5" Or Target.Address(0, 0) = "B7" Then
Range("A21").Interior.ColorIndex = 48
Else
Range("A21").Interior.ColorIndex = 2
End If

If Target.Address(0, 0) = "E5" Or Target.Address(0, 0) = "E7" Then
Range("A22").Interior.ColorIndex = 48
Else
Range("A22").Interior.ColorIndex = 2
End If

If Target.Address(0, 0) = "H5" Or Target.Address(0, 0) = "H7" Then
Range("A23").Interior.ColorIndex = 48
Else
Range("A23").Interior.ColorIndex = 2
End If

If Target.Address(0, 0) = "B5" Or Target.Address(0, 0) = "B8" Then
Range("A24").Interior.ColorIndex = 48
Else
Range("A24").Interior.ColorIndex = 2
End If

If Target.Address(0, 0) = "E5" Or Target.Address(0, 0) = "E8" Then
Range("A25").Interior.ColorIndex = 48
Else
Range("A25").Interior.ColorIndex = 2
End If

If Target.Address(0, 0) = "H5" Or Target.Address(0, 0) = "H8" Then
Range("A26").Interior.ColorIndex = 48
Else
Range("A26").Interior.ColorIndex = 2
End If

If Target.Address(0, 0) = "B6" Or Target.Address(0, 0) = "B7" Then
Range("A27").Interior.ColorIndex = 48
Else
Range("A27").Interior.ColorIndex = 2
End If

If Target.Address(0, 0) = "E6" Or Target.Address(0, 0) = "E7" Then
Range("A28").Interior.ColorIndex = 48
Else
Range("A28").Interior.ColorIndex = 2
End If

If Target.Address(0, 0) = "H6" Or Target.Address(0, 0) = "H7" Then
Range("A29").Interior.ColorIndex = 48
Else
Range("A29").Interior.ColorIndex = 2
End If


End Sub

un bug type 1004 sur le pastespecial apparait.....

 

[Guest]

Re : Couleur de Cellule en fonction d'une sélection

re,

Peut-être qu'un fichier exemple s'impose Non?

Tu peux toujours essayer de remplacer ta macro2 par les lignes ci-dessous.
Saches que les codes passés sur les posts sans les balises idoines sont très difficiles à lire et n'incite pas à répondre. Va dans l'éditeur avancé des posts pour rédiger tes messages.

Sub Macro2()
'
' Macro2 Macro
' Macro enregistrée le 09/11/2011 par Jul
'
'   'éviter d'appeler l'évènement Selection_Change de la feuille
    Application.EnableEvents = False
    Range("K4:P16").Copy
    Range("Q4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                  :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("Q5:V16").Sort Key1:=Range("V5"), Order1:=xlAscending, Header:=xlGuess, _
                   OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                   DataOption1:=xlSortNormal
    Range("E11").Select
    Application.EnableEvents = False
End Sub

A+

 

[orion2000]

Re : Couleur de Cellule en fonction d'une sélection

Re j'ai testé la nouvelle macro elle n'a fonctionner qu'une fois, je cherche le moyen d'envoyer le fichier qui pour le moment est trop gros

A+

 

[orion2000]

Re : Couleur de Cellule en fonction d'une sélection

Voila la source de tout mes problèmes....