Une macro pour insérer une caractère

Option Explicit
Dim stopEvents As Boolean

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim i As Long, ch As String
    If Intersect(Target, Range("A2:C10")) Is Nothing Then Exit Sub
    If Target.Count > 1 Or stopEvents Then Exit Sub
    ch = Target
    While InStr(ch, "/p") > 0
        ch = Replace(ch, "/p", ChrW(&H2660))
    Wend
    While InStr(ch, "/c") > 0
        ch = Replace(ch, "/c", ChrW(&H2665))
    Wend
    While InStr(ch, "/k") > 0
        ch = Replace(ch, "/k", ChrW(&H2666))
    Wend
    While InStr(ch, "/t") > 0
        ch = Replace(ch, "/t", ChrW(&H2663))
    Wend
    stopEvents = True
    Target = ch
    stopEvents = False
    'rouge
    For i = 1 To Len(Target)
        If Mid(Target, i, 1) = ChrW(&H2665) Or Mid(Target, i, 1) = ChrW(&H2666) Then
            Target.Characters(i, 1).Font.ColorIndex = 3
        End If
    Next i
End Sub