Microsoft 365 Liste de choix...

Private Sub Worksheet_Change(ByVal Target As Range)
Set Target = Intersect(Target, [J7:J37])
If Target Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each Target In Target 'si entrées multiples (copier-coller)
    Target.Font.Color = IIf(Target = "bas", vbRed, vbGreen)
    Target = IIf(Target = "bas", "ê", IIf(Target = "haut", "é", ""))
Next
Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim s As Shape, i As Byte
For Each s In Shapes
    If Not Intersect(s.TopLeftCell, [L7:L37]) Is Nothing Then s.Delete
Next
Set Target = Intersect(ActiveCell, [J7:J37])
If Target Is Nothing Then Exit Sub
Application.ScreenUpdating = False
For i = 1 To 2
    [P7].Cells(i).CopyPicture
    Me.Paste
    With Selection
        .Left = ActiveCell(1, 3).Left
        .Top = ActiveCell(i, 3).Top
        .OnAction = Me.CodeName & ".Macro"
        .Name = IIf(i = 1, "é", "ê")
    End With
    ActiveCell.Activate
Next
End Sub

Sub Macro()
If Not IsError(Application.Caller) Then ActiveCell = Application.Caller
End Sub