Formule pour mise en forme

Option Explicit

Sub Traitement()    'd'après myDearFriend!  -  [url=http://www.mdf-xlpages.com]mon Univers Excel... : myDearFriend! Excel Pages[/url]
    Dim LaPhrase As Range, Cel As Range
    Dim LeMot As String, AdrDeb As String
    Dim NumL&


    NumL = InputBox("Choix de la ligne", "Choisir...", 2)


    'A adapter -----------------------------------
    Range("G6") = NumL
    Range("H6").Formula = _
    "=VLOOKUP(R6C7,Base,2,0)&"" ""&VLOOKUP(R6C7,Base,3,0)&"" ""&VLOOKUP(R6C7,Base,4,0)"
    Set LaPhrase = Feuil1.Range("H6")
    LaPhrase = LaPhrase.Value


    Range("G1").Formula = "=MID(R[5]C[1],LEN(VLOOKUP(R6C7,Base,2,0))+2,LEN(VLOOKUP(R6C7,Base,3,0)))"
    LeMot = Feuil1.Range("G1")
    Feuil1.Range("G1") = Feuil1.Range("G1").Value
    ' --------------------------------------------
    Application.ScreenUpdating = False


    With LaPhrase
        .Font.ColorIndex = 0
        .Font.Bold = False


        Set Cel = .Find(LeMot, LookAt:=xlPart)
        If Not Cel Is Nothing Then
            AdrDeb = Cel.Address
            Do
                Modif Cel, LeMot
                Set Cel = .FindNext(Cel)
            Loop While Not Cel Is Nothing And AdrDeb <> Cel.Address
        End If
    End With
    Range("G1").ClearContents
    Application.ScreenUpdating = True
End Sub


Private Sub Modif(ByRef Cel As Range, LeMot)
    Dim T As String
    Dim Pos As Integer
    T = Cel.Text
    Do
        'Pos = InStr(Pos + 1, T, LeMot) 'sensible à la casse
        Pos = InStr(Pos + 1, T, LeMot, vbTextCompare)    ' insensible à la casse
        If Pos > 0 Then
            With Cel.Characters(Start:=Pos, Length:=Len(LeMot)).Font
                .FontStyle = "Gras"
                .ColorIndex = 3     'rouge
            End With
        End If
    Loop Until Pos = 0
End Sub