Sub RechercherPartout()
Dim Txt As String, F As Worksheet, Adr As String, Cel As Range, AncPosC As Long, Des As Shape, TxtDes As String
Txt = UCase(InputBox("Texte à rechercher", "Rechercher partout"))
If Txt = "" Then Exit Sub
For Each F In ActiveWorkbook.Worksheets
Set Cel = F.Cells.Find(What:=Txt, LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If Not Cel Is Nothing Then
Adr = Cel.Address
Do
F.Activate: Cel.Select
If MsgBox("Cellule " & Cel.Address(False, False) & " :" & vbLf & Trim$(Cel.Value) _
& vbLf & "___________" & vbLf & "Continuer ?", vbYesNo, "Recherche """ & Txt & """.") = vbNo Then Exit Sub
Set Cel = F.Cells.FindNext(After:=Cel)
If Cel Is Nothing Then Exit Do
Loop Until Cel.Address = Adr
End If
For Each Des In F.Shapes
On Error Resume Next: TxtDes = "": TxtDes = Des.TextFrame.Characters.Text: On Error GoTo 0
If TxtDes Like "*" & Txt & "*" Then
Set Cel = Application.Range(Des.TopLeftCell, Des.BottomRightCell)
F.Activate: Cel.Select
If MsgBox("Texte dans " & Cel.Address(False, False) & " :" & vbLf & Trim$(TxtDes) _
& vbLf & "___________" & vbLf & "Continuer ?", vbYesNo, "Recherche """ & Txt & """.") = vbNo Then Exit Sub
End If
Next Des
Next F
End Sub