Re : Copier la couleur d'une cellule dans une autre sur une autre feuille
Quelqu'un aurait'il une idée car là je ne vois pas du tout.
Lorsque je met cela, ça ne fonctionne pas : comment lui dire d'envoyer à 2 endroits différents?????
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim Coul, Est As Range, Li As Long
If Sh.Name = "Synthèse par domaine" and "Bilan s" Or Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("BU58,BU64:BU65,BU67,BU76,BU80:BU82,BU89:BU92")) Is Nothing Then
Coul = Target.Interior.ColorIndex
Target.Interior.ColorIndex = IIf(Coul = xlNone, 4, IIf(Coul = 4, 6, IIf(Coul = 6, 3, xlNone)))
With Sheets("Synthèse par domaine" and "Bilan s)
Set Est = .Rows(8).Find(Target.Offset(, -72))
If Not Est Is Nothing Then
For Li = 11 To .Cells(Rows.Count, "P").End(xlUp).Row
If .Cells(Li, "P") = Sh.Name Then Target.Copy .Cells(Li, Est.Column): Exit For
Next
End If
End With
Application.EnableEvents = False: Target.Offset(, 1).Select: Application.EnableEvents = True
Else
'Deuxième partie à voir et orriger éventuellement
Dim aa
If Target.Column > 60 And Target.Row > 5 Then
Application.ScreenUpdating = False
aa = Target.Interior.ColorIndex
If Target.Interior.ColorIndex < 0 Then aa = 0 '????
Select Case aa
Case 15
Target.Interior.ColorIndex = 4
Case 4
Target.Interior.ColorIndex = 3
Case 3
Target.Interior.ColorIndex = 15
Case Else
Exit Sub
'Ne rien faire si la cellule ne contient ni V ni NA ni NE
End Select
Application.EnableEvents = False: Range("BX" & lig).Select: Application.EnableEvents = True
End If
End If
End Sub
Merci d'avance
lolomal