XL 2016 VBA - Mettre en Indice une partie du contenu d'une cellule : problème avec la propriété Font.Subscript

[crocrocro]

Bonjour,
La propriété Font.Subscript qui permet de mettre en Indice (ou de l'enlever) une partie du contenu de la cellule ne fonctionne pas correctement lorsque le contenu de la cellule à des caractéristique de police (Exposant - Indice - Normal) hétérogène.
Au moins dans mon code 😠
Voici un exemple de résultats obtenus

Le code

Option Explicit
Sub CaractèresIndicésNonIndicés()
Dim i As Integer
Dim Message As String
    Application.ScreenUpdating = False
    Message = "Liste des caractères passés de Indicé à Non Indicé :"
    For i = 1 To Len(ActiveCell.Value)
        If ActiveCell.Characters(i, 1).Font.Subscript = True Then
            ActiveCell.Characters(i, 1).Font.Subscript = False
            Message = Message & vbLf & i & "ème caractère : " & ActiveCell.Characters(i, 1).Caption
        End If
    Next i
    Application.ScreenUpdating = True
    MsgBox Message
End Sub
Sub ChiffresEnIndicés()
Dim i As Integer
Dim CaractèreCourant As String
Dim Message As String
    Application.ScreenUpdating = False
    Message = "Liste des caractères passés en Indicés :"
    For i = 1 To Len(ActiveCell.Value)
        CaractèreCourant = Mid(ActiveCell.Value, i, 1)
        If CaractèreCourant >= "0" And CaractèreCourant <= "9" Then
            ActiveCell.Characters(i, 1).Font.Subscript = True
            Message = Message & vbLf & i & "ème caractère : " & ActiveCell.Characters(i, 1).Caption
        End If
    Next i
    Application.ScreenUpdating = True
    MsgBox Message
End Sub

Sub NonChiffresEnNonIndicés()

Dim i As Integer
Dim CaractèreCourant As String
Dim Message As String
    Application.ScreenUpdating = False
    Message = "Liste des caractères passés en Non Indicés :"
    For i = 1 To Len(ActiveCell.Value)
        CaractèreCourant = Mid(ActiveCell.Value, i, 1)
        If CaractèreCourant < "0" Or CaractèreCourant > "9" Then
            ActiveCell.Characters(i, 1).Font.Subscript = False
            Message = Message & vbLf & i & "ème caractère : " & ActiveCell.Characters(i, 1).Caption
        End If
    Next i
    Application.ScreenUpdating = True
    MsgBox Message
End Sub

En PJ, le fichier correspondant.
Merci d'avance à la personne qui m'indiquera ma (ou mes) erreur(s) ...

 

[Gégé-45550]

Bonjour,
La propriété Font.Subscript qui permet de mettre en Indice (ou de l'enlever) une partie du contenu de la cellule ne fonctionne pas correctement lorsque le contenu de la cellule à des caractéristique de police (Exposant - Indice - Normal) hétérogène.
Au moins dans mon code 😠
Voici un exemple de résultats obtenus
Regarde la pièce jointe 1212570
Le code

Option Explicit
Sub CaractèresIndicésNonIndicés()
Dim i As Integer
Dim Message As String
    Application.ScreenUpdating = False
    Message = "Liste des caractères passés de Indicé à Non Indicé :"
    For i = 1 To Len(ActiveCell.Value)
        If ActiveCell.Characters(i, 1).Font.Subscript = True Then
            ActiveCell.Characters(i, 1).Font.Subscript = False
            Message = Message & vbLf & i & "ème caractère : " & ActiveCell.Characters(i, 1).Caption
        End If
    Next i
    Application.ScreenUpdating = True
    MsgBox Message
End Sub
Sub ChiffresEnIndicés()
Dim i As Integer
Dim CaractèreCourant As String
Dim Message As String
    Application.ScreenUpdating = False
    Message = "Liste des caractères passés en Indicés :"
    For i = 1 To Len(ActiveCell.Value)
        CaractèreCourant = Mid(ActiveCell.Value, i, 1)
        If CaractèreCourant >= "0" And CaractèreCourant <= "9" Then
            ActiveCell.Characters(i, 1).Font.Subscript = True
            Message = Message & vbLf & i & "ème caractère : " & ActiveCell.Characters(i, 1).Caption
        End If
    Next i
    Application.ScreenUpdating = True
    MsgBox Message
End Sub

Sub NonChiffresEnNonIndicés()

Dim i As Integer
Dim CaractèreCourant As String
Dim Message As String
    Application.ScreenUpdating = False
    Message = "Liste des caractères passés en Non Indicés :"
    For i = 1 To Len(ActiveCell.Value)
        CaractèreCourant = Mid(ActiveCell.Value, i, 1)
        If CaractèreCourant < "0" Or CaractèreCourant > "9" Then
            ActiveCell.Characters(i, 1).Font.Subscript = False
            Message = Message & vbLf & i & "ème caractère : " & ActiveCell.Characters(i, 1).Caption
        End If
    Next i
    Application.ScreenUpdating = True
    MsgBox Message
End Sub

En PJ, le fichier correspondant.
Merci d'avance à la personne qui m'indiquera ma (ou mes) erreur(s) ...

Bonsoir,
Bizarrement, si on reprend toutes les propriétés du caractère à modifier, ça marche.
Encore un comportement plutôt étrange d'Excel.

Sub CaractèresIndicésNonIndicés()
Dim i As Integer
Dim Message As String
    Application.ScreenUpdating = False
    Message = "Liste des caractères passés de Indicé à Non Indicé :"
    For i = 1 To Len(ActiveCell.Value)
        If ActiveCell.Characters(i, 1).Font.Subscript = True Then
            With ActiveCell.Characters(Start:=i, Length:=1).Font
                .Name = "Calibri"
                .FontStyle = "Normal"
                .Size = 18
                .Strikethrough = False
                .Superscript = False
                .Subscript = False
                .OutlineFont = False
                .Shadow = False
                .Underline = xlUnderlineStyleNone
                .ThemeColor = xlThemeColorLight1
                .TintAndShade = 0
                .ThemeFont = xlThemeFontMinor
            End With
            Message = Message & vbLf & i & "ème caractère : " & ActiveCell.Characters(i, 1).Caption
        End If
    Next i
    Application.ScreenUpdating = True
    MsgBox Message
End Sub

Cordialement,

 

[crocrocro]

Bonjour @Gégé-45550 , merci pour votre retour mais chez moi, votre code ne fonctionne pas :
Tous les caractères passent en non indicés et pas seulement les non-indicés (ici 34).
De plus, on perd la couleur, ici rouge pour 34.
Je ne l'ai pas écrit, mais le code devant fonctionner quelle que soit la police, je ne dois pas mettre "en dur" les caractéristiques.

Et, comme vous le dites, une nouvelle bizarrerie d'Excel.
J'ai déjà constaté qu'Excel était (très ?) mauvais pour tout ce qui concerne la mise en forme sélective (par caractère) du contenu d'une cellule.
Je suis en train de finir de mettre au point un outil équivalent à la fonction Rechercher-Remplacer d'Excel qui présente pas mal d'inconvénients résumés ici