Sub FindHighlight()
    Dim Ret As Variant
    Dim InitialColor As Variant
    Dim InitialColorIndex As Variant
    Dim ErrorNumber As Integer
    Dim SearchString As Variant
    Dim FirstOccurrenceAddress As String
    Dim Found, InitialSearch As Boolean
    Dim Arrow As Excel.Shape
    SearchString = Null
    
    Const NbColorHighlight = 1      '0 = aucune couleur, 1 = jaune uniquement, 2 = jaune sauf pour les cellules de fond proche du jaune, bleu
    Const WarningSearchLoop = True  'True si message lors du retour sur la 1ère occurrence de Search, False si pas de message
    Const ShowArrow = True          'Montre une flèche sur la cellule adjacente droite
    
    Do While (1)
        Ret = Application.InputBox("Rechercher quoi ?", "Recherche", Default:=SearchString, Type:=2)
        
        'Cellule précédemment trouvée
        If Found Then
            'Restore la couleur originale de la cellule précédemment trouvée
            If NbColorHighlight > 0 Then
                If InitialColorIndex = xlColorIndexAutomatic Or InitialColorIndex = xlColorIndexNone Then
                    'ActiveCell.Interior.Color = InitialColor
                    ActiveCell.Interior.ColorIndex = InitialColorIndex
                Else
                    'ActiveCell.Interior.ColorIndex = InitialColorIndex
                    ActiveCell.Interior.Color = InitialColor
                End If
            End If
            'Efface la flèche sur le cellule adjacente droite de al cellule précedemment trouvée
            If ShowArrow Then
                Arrow.Delete
            End If
        End If
        
        'Touche Annuler ou rien de saisi, on sort de la Macro
        If VarType(Ret) = vbBoolean Then Exit Sub
        If Len(Ret) = 0 Then Exit Sub
        
        'Recherche initiale
        If Not Found Or Ret <> SearchString Then
            InitialSearch = True
            SearchString = Ret
            On Error Resume Next
            Cells.Find(What:=SearchString, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , SearchFormat:=False).Activate
            ErrorNumber = Err.Number
            On Error GoTo 0
            If ErrorNumber = 0 Then FirstOccurrenceAddress = ActiveCell.Address
            
        'Recherche suivante
        Else
            InitialSearch = False
            Cells.FindNext(After:=ActiveCell).Activate
        End If
            
        'Si erreur en recherche initiale, pas de résultat
        If ErrorNumber Then
            Found = False
            MsgBox """" & Ret & """ non trouvé"
        
        'Sinon colorise la cellule trouvée
        Else
            Found = True
            
            'Colorise la cellule selon la couleur déjà présente (ColorIndex 6, 19, 27, 36 sont des jaunes)
            If NbColorHighlight > 0 Then
                'Save couleur de fond de la cellule
                InitialColor = ActiveCell.Interior.Color
                InitialColorIndex = ActiveCell.Interior.ColorIndex
                            
                'Colorise le fond de la cellule
                If NbColorHighlight > 1 _
                And (ActiveCell.Interior.ColorIndex = 6 _
                Or ActiveCell.Interior.ColorIndex = 19 _
                Or ActiveCell.Interior.ColorIndex = 27 _
                Or ActiveCell.Interior.ColorIndex = 36) _
                Then
                    ActiveCell.Interior.ColorIndex = 8  'Bleu
                Else
                    ActiveCell.Interior.ColorIndex = 6  'Jaune
                End If
            End If
            
            'Fait appraitre une flèche sur la cellule adjacente droite
            If ShowArrow Then
                Set Arrow = ActiveSheet.Shapes.AddShape(msoShapeLeftArrow, ActiveCell.Offset(0, 1).Left, ActiveCell.Offset(0, 1).Top, _
                        ActiveCell.Offset(0, 2).Left - ActiveCell.Offset(0, 1).Left, ActiveCell.Offset(1, 1).Top - ActiveCell.Offset(0, 1).Top)
                
                'Couleurs de la flèche
                With Arrow.Fill
                    .Visible = msoTrue
                    .ForeColor.ObjectThemeColor = msoThemeColorAccent2
                    .ForeColor.TintAndShade = 0
                    .ForeColor.Brightness = 0
                    .Transparency = 0
                    .Solid
                End With
                With Arrow.Line
                    .Visible = msoTrue
                    .ForeColor.RGB = RGB(0, 112, 192)
                    .Transparency = 0
                End With
                
                'Required to display the Shape before InputBox ! (Believe it ?)
                Application.ScreenUpdating = True
            End If
            
            'Si boucle sur la 1ère occurrence on le signale
            If WarningSearchLoop _
            And Not InitialSearch And ActiveCell.Address = FirstOccurrenceAddress Then
                MsgBox "Retour sur la 1ère occurrence trouvée"
            End If
        End If
    Loop
    
End Sub