Macro pour replacer mot avec nouvelle mise en forme

Sub Macro1()
ActiveCell.Characters(Start:=7, Length:=6).Font.Subscript = True
End Sub

Sub SubstituerFormatTexte()
Dim rgOu As Range, xCell As Range, Quoi As Range, N&, i&

On Error GoTo FIN
  'zone de recherche
  Set rgOu = Application.InputBox(prompt:="Sélectionner la zone de recherche:", Type:=8)
  'cellule où se trouve le texte et le format à apppliquer
  Set Quoi = Application.InputBox(prompt:="Cellule contenant l'expression formatée finale?", Type:=8)
  If Quoi Is Nothing Then Exit Sub
  If IsEmpty(Quoi) Then Exit Sub
  If Not Intersect(rgOu, Quoi) Is Nothing Then Exit Sub
  Set Quoi = Quoi(1, 1)

Application.ScreenUpdating = False
On Error Resume Next
  For Each xCell In rgOu
    'pour chaque cellule de la zone de recherche
    'recherche du mot à formater
    N = InStr(1, xCell, Quoi, vbTextCompare)
    If N > 0 Then
    'le mot est dans la cellule
      'boucle sur chaque apparition du mot dans la cellule
      Do
        ' boucle sur chaque du mot trouvé
        For i = 1 To Len(Quoi)
          'test sur le caractère final, est il en en majuscule ou non ?
          If Asc(Quoi.Characters(i, 1).Text) = Asc(UCase(Quoi.Characters(i, 1).Text)) Then
            'il est en majuscule
            xCell.Characters(N + i - 1, 1).Text = UCase(Quoi.Characters(i, 1).Text)
          Else
            'il n'est pas en majuscule donc il est en minuscule
            xCell.Characters(N + i - 1, 1).Text = LCase(Quoi.Characters(i, 1).Text)
          End If
          'on applique au caractère de la cellule le format du même caractère dans Quoi
          xCell.Characters(N + i - 1, 1).Font.Bold = Quoi.Characters(i, 1).Font.Bold
          xCell.Characters(N + i - 1, 1).Font.Color = Quoi.Characters(i, 1).Font.Color
          xCell.Characters(N + i - 1, 1).Font.ColorIndex = Quoi.Characters(i, 1).Font.ColorIndex
          xCell.Characters(N + i - 1, 1).Font.FontStyle = Quoi.Characters(i, 1).Font.FontStyle
          xCell.Characters(N + i - 1, 1).Font.Italic = Quoi.Characters(i, 1).Font.Italic
          xCell.Characters(N + i - 1, 1).Font.Name = Quoi.Characters(i, 1).Font.Name
          xCell.Characters(N + i - 1, 1).Font.Size = Quoi.Characters(i, 1).Font.Size
          xCell.Characters(N + i - 1, 1).Font.Strikethrough = Quoi.Characters(i, 1).Font.Strikethrough
          xCell.Characters(N + i - 1, 1).Font.Subscript = Quoi.Characters(i, 1).Font.Subscript
          xCell.Characters(N + i - 1, 1).Font.Superscript = Quoi.Characters(i, 1).Font.Superscript
          xCell.Characters(N + i - 1, 1).Font.ThemeColor = Quoi.Characters(i, 1).Font.ThemeColor
          xCell.Characters(N + i - 1, 1).Font.ThemeFont = Quoi.Characters(i, 1).Font.ThemeFont
          xCell.Characters(N + i - 1, 1).Font.TintAndShade = Quoi.Characters(i, 1).Font.TintAndShade
          xCell.Characters(N + i - 1, 1).Font.Underline = Quoi.Characters(i, 1).Font.Underline
        'on passe au caractère suivant
        Next i
          'on cherche l'apparition du mot Quoi dans le reste de la cellule
          N = InStr(N + Len(Quoi), xCell, Quoi, vbTextCompare )
          'si le mot n'y figure plus, on sort de la boucle sur la cellule
      Loop Until N = 0
    End If
  'on passe à la cellule suivante
  Next xCell

FIN:
Application.ScreenUpdating = True
End Sub