Salut Bayard, gmb,
même technique en poussant le bouchon un peu plus loin encore!
Pour certaines recettes, le mot à trouver peut faire partie d'un autre mot (ail -> écailles, rougail).
Les mots à chercher sont à taper au singulier.
A tester en situation réelle car, sûrement, des exceptions n'auront pas été relevées!
Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim tWks, tSplit, tRec()
'
Application.EnableEvents = False
If Not Intersect(Target, Range("A3")) Is Nothing Then
sProd = LCase([A3])
iRow = Cells(Rows.Count, 1).End(xlUp).Row
If iRow > 5 Then Range("A6:D" & iRow).ClearContents
'
For x = 1 To Sheets.Count
sFlag = Sheets(x).Name
If sFlag <> "Recherche" Then
With Worksheets(sFlag)
iRow = .Cells(Rows.Count, 1).End(xlUp).Row
tWks = .Range("A2:D" & iRow)
End With
For y = 1 To UBound(tWks, 1)
tSplit = Split(LCase(tWks(y, 3)), " ")
For Z = 0 To UBound(tSplit)
If tSplit(Z) Like "*" & sProd & "*" Then
iOK = 1
If Len(tSplit(Z)) > Len(sProd) Then
iOK = 0
iInstr = InStr(tSplit(Z), sProd)
Select Case iInstr
Case 1
If Mid(tSplit(Z), Len(sProd) + 1, 1) = "s" Or Mid(tSplit(Z), Len(sProd) + 1, 1) = "," Then iOK = 1
Case Else
If Mid(tSplit(Z), iInstr - 1, 1) = "'" Or Mid(tSplit(Z), iInstr - 1, 1) = "-" Then iOK = 1
End Select
End If
If iOK = 1 Then
iIdx = iIdx + 1
ReDim Preserve tRec(3, iIdx)
For k = 1 To 4
tRec(k - 1, iIdx - 1) = tWks(y, k)
Next
Exit For
End If
End If
Next
Next
End If
Next
If iIdx > 0 Then Range("A6").Resize(iIdx, 4) = WorksheetFunction.Transpose(tRec)
End If
Application.EnableEvents = True
'
End Sub
Pour le plaisir du code!
A+