Masquer une partie des caractères d'une même cellule

Private Sub Worksheet_Change(ByVal Target As Range)
    With Application.ErrorCheckingOptions
        .EvaluateToError = False
        .TextDate = False
        .NumberAsText = False
    End With

    If Target.Count > 1 Then Exit Sub
    If Not Application.Intersect(Target, Range("D2:D12")) Is Nothing Then
        With Target
            .NumberFormat = "@"
            NbC = Len(Target)
            If NbC < 3 Then
                .Characters(Start:=1, Length:=NbC).Font.ColorIndex = xlAutomatic
            Else
                Lng = NbC - 1
                .Characters(1, Lng).Font.Color = vbWhite
                .Characters(Start:=Lng, Length:=2).Font.ColorIndex = xlAutomatic
            End If
            .HorizontalAlignment = xlRight
        End With
    End If
End Sub