***************************
Sub MoteurRecherche()
Dim couleur
Dim reponse
Dim var
Dim T()
Dim A$
Dim B$
Dim Nom$
Dim Lien$
Dim g&
Dim h&
Dim i&
Dim j&
Dim cpt&
Dim lig&
Dim valide&
Dim R As Range
Dim R2 As Range
Dim R3 As Range
Dim bool As Boolean
Dim S As Worksheet
Dim DEST As Worksheet
On Error GoTo Erreur
couleur = Array(, 5, 3, 50, 46, 13, 16, 7, 9, _
5, 3, 50, 46, 13, 16, 7, 9)
reponse = Application.InputBox(prompt:= _
"Tapez les mots à rechercher en les séparant par au moins un espace", _
Title:="Moteur de recherche", Type:=1 + 2)
If reponse = False Or reponse = "" Then Exit Sub
reponse = Trim(CStr(reponse))
A$ = reponse
If InStr(1, A$, Space(1)) = 0 Then
ReDim Preserve T(1 To 1)
T(1) = A$
A$ = ""
End If
Do Until A$ = ""
cpt& = cpt& + 1
ReDim Preserve T(1 To cpt&)
i& = InStr(1, A$, Space(1))
If i& > 0 Then
B$ = Mid(A$, 1, i& - 1)
T(cpt&) = B$
A$ = Trim(Mid(A$, i& + 1))
Else
T(cpt&) = A$
A$ = ""
End If
Loop
'------------------
cpt& = 0
Nom$ = "*Recherche"
Do Until bool
For i& = 1 To Sheets.Count
bool = True
If Sheets(i&).Name = Nom$ Then
cpt& = cpt& + 1
Nom$ = "*Recherche (" & cpt& & ")"
bool = False
Exit For
End If
Next i&
Loop
Application.ScreenUpdating = False
bool = False
Set DEST = Sheets.Add(after:=Sheets(Sheets.Count))
DEST.Name = Nom$
For h& = 1 To ActiveWorkbook.Worksheets.Count - 1
Set S = Sheets(h&)
If InStr(1, S.Name, "*Recherche") > 0 Then GoTo saut
If S.UsedRange.Address = "$A$1" Then
If S.[a1] = "" Then GoTo saut
Set R = S.[a1]
A$ = R
i& = 1
j& = 1
GoSub Recherche
Else
Set R = S.UsedRange
var = R
For j& = 1 To UBound(var, 2)
For i& = 1 To UBound(var, 1)
A$ = LCase(var(i&, j&))
GoSub Recherche
Next i&
Next j&
End If
saut:
Next h&
With DEST.Cells
.EntireColumn.AutoFit
If DEST.Columns("b").ColumnWidth < 130 Then _
DEST.Columns("b").ColumnWidth = 130
.VerticalAlignment = xlTop
.WrapText = True
.EntireRow.AutoFit
End With
'------------------
If Not bool Then
Application.DisplayAlerts = False
DEST.Delete
Application.DisplayAlerts = True
MsgBox "Aucune cellule ne contient tous les mots recherchés."
End If
Erreur:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox "Erreur " & _
Err.Number & vbCrLf & Err.Description
Exit Sub
'----- Sous routine -----
Recherche:
valide& = 0
For g& = 1 To UBound(T)
If InStr(1, A$, LCase(T(g&))) > 0 Then
valide& = valide& + 1
End If
Next g&
If valide& = UBound(T) Then
bool = True
Set R2 = S.Range(S.Cells(i& + R.Row - 1, j& + R.Column - 1), _
S.Cells(i& + R.Row - 1, j& + R.Column - 1))
R2.Copy
If DEST.[b1] = "" Then
lig& = 1
Else
lig& = DEST.UsedRange.Rows.Count + 1
End If
DEST.Paste Destination:=DEST.Range("b" & lig& & "")
Set R3 = DEST.Range("b" & lig& & "")
With R3.Font
.Bold = False
.ColorIndex = 0
End With
cpt& = 1
For g& = 1 To UBound(T)
cpt& = InStr(cpt&, LCase(R3), T(g&))
Do Until cpt& = 0
With R3.Characters(Start:=cpt&, Length:=Len(T(g&))).Font
.ColorIndex = couleur(g&)
.Bold = True
End With
cpt& = InStr(cpt& + Len(T(g&)) - 1, R2, T(g&))
Loop
cpt& = 1
Next g&
Lien$ = Chr(39) & R2.Parent.Name & Chr(39) & _
"!" & R2.Address(False, False)
DEST.Hyperlinks.Add Anchor:=DEST.Range("a" & lig& & ""), _
Address:="", SubAddress:=Lien$, TextToDisplay:=Lien$
End If
Return
End Sub
***************************
Voila ce que je recherche 
