Option Explicit Const ColSource As String = "B" 'colonne source des couleurs Dim PrecedenteCellule As Range, CouleurPrecedenteCellule As Variant Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error Resume Next 'ici on recupere les info sur la/les cellule(s) precedente(s) 'les cellules Z1 et Z2 sont des choix arbitraires qui ne servent qu'a conserver ce qui nous interesses Set PrecedenteCellule = Me.Range(Range("Z1").Value) CouleurPrecedenteCellule = Me.Range("Z2").Value On Error GoTo 0 If Not PrecedenteCellule Is Nothing Then 'cas des cellules en Z vide ou ne contenant pas d'adresse If Not CouleurPrecedenteCellule = PrecedenteCellule.Cells(1, 1).Interior.ColorIndex Then Dim Cellule As Range For Each Cellule In PrecedenteCellule 'ici il faut adapter le code au type d'objet qui doit changer de couleur 'pour la demo on change la couleur de la cellule limitrophe à la colonne source If Cellule.Column = Columns(ColSource).Column Then Cellule.Offset(0, 1).Interior.ColorIndex = Cellule.Interior.ColorIndex End If Next End If End If If Not Intersect(Target, Columns(ColSource)) Is Nothing Then 'si la selection croise la colonne source 'on enregistre les info de la selection courante Range("Z1").Value = Me.Target.Address Range("Z2").Value = Me.Target.Cells(1, 1).Interior.ColorIndex End If End Sub
Option Explicit Const ColSource As String = "B" 'colonne source des couleurs Dim PrecedenteCellule As Range, CouleurPrecedenteCellule As Variant Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error Resume Next 'ici on recupere les info sur la/les cellule(s) precedente(s) 'les cellules Z1 et Z2 sont des choix arbitraires qui ne servent qu'a conserver ce qui nous interesses Set PrecedenteCellule = Me.Range(Range("Z1").Value) CouleurPrecedenteCellule = Me.Range("Z2").Value On Error GoTo 0 If Not PrecedenteCellule Is Nothing Then 'cas des cellules en Z vide ou ne contenant pas d'adresse If Not CouleurPrecedenteCellule = PrecedenteCellule.Cells(1, 1).Interior.ColorIndex Then Dim Cellule As Range For Each Cellule In PrecedenteCellule 'ici il faut adapter le code au type d'objet qui doit changer de couleur 'pour la demo on change la couleur de la cellule limitrophe à la colonne source If Cellule.Column = Me.Columns(ColSource).Column Then Cellule.Offset(0, 1).Interior.ColorIndex = Cellule.Interior.ColorIndex End If Next End If End If If Not Intersect(Target, Me.Columns(ColSource)) Is Nothing Then 'si la selection croise la colonne source 'on enregistre les info de la selection courante Range("Z1").Value = Target.Address Range("Z2").Value = Target.Cells(1, 1).Interior.ColorIndex End If End Sub
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionPrivate Sub Worksheet_SelectionChange(ByVal Target As Range) Dim R As Range Set R = Application.Intersect(Range("a1:a45"), Target) If R Is Nothing Then Call OffTimer Else Call RunTimer(100) End If End Sub
Private OnTimer& Private Declare Function SetTimer& Lib "user32" _ (ByVal hwnd As Long, ByVal nIDEvent As Long, _ ByVal uElapse As Long, ByVal lpTimerFunc As Long) Private Declare Function KillTimer& Lib "user32" _ (ByVal hwnd As Long, ByVal nIDEvent As Long) Sub LaunchTimer(Optional dummy As Byte) Call OffTimer On Error Resume Next Application.OnTime Now + TimeValue("00:00:01"), "ChangeLineColor" End Sub Sub ChangeLineColor(Optional dummy As Byte) Dim SH As Shape Dim R As Range Dim R2 As Range Set R = ActiveCell Set R2 = Application.Intersect(Range("a1:a45"), R) If Not R2 Is Nothing Then For Each SH In ActiveSheet.Shapes If SH.Type msoLine Then 'msoLine Trait If R.Row = SH.TopLeftCell.Row Then SH.Line.ForeColor.RGB = R.Interior.Color Exit For End If End If Next SH Call RunTimer(100) End If End Sub Sub RunTimer(Delai&) If OnTimer& > 0 Then OffTimer OnTimer& = SetTimer(0, 0, ByVal Delai&, AddressOf LaunchTimer) End Sub Sub OffTimer(Optional dummy As Byte) If OnTimer& > 0 Then OnTimer& = KillTimer(0&, OnTimer&) OnTimer& = 0 End If End Sub