Option Explicit
Sub filtrer()
Dim A, c, reponse As String, s As Byte, i&, j&, k&, l&, Nb&, Pl As Range
On Error GoTo Erreur
Sheets("RésultatRecherche").Range("A6:A100").ClearContents
A = Split(Extractions(Sans_accents(InputBox("Texte ou expression à rechercher")), " +", " ")) 'suite aux conseils avisés de staple
l = 1
For s = 1 To Sheets.Count
If Sheets(s).Name <> "RésultatRecherche" Then
With Sheets(s)
Set Pl = Sheets(s).Range("A2").CurrentRegion.Offset(1) _
.Resize(Sheets(s).Range("A2").CurrentRegion.Rows.Count - 1)
End With
Dim b(), d()
i = 1
ReDim b(1 To Pl.Cells.Count, 2)
For j = 1 To Pl.Columns.Count
For k = 1 To Pl.Rows.Count
b(i, 0) = Replace(Sans_accents(Pl(k, j)), ",", "")
b(i, 1) = Pl(k, j)
b(i, 2) = Sheets(s).Name & "#" & Pl(k, j).Address
i = i + 1
Next k
Next j
For i = LBound(b) To UBound(b)
c = Split(b(i, 0))
For j = LBound(A) To UBound(A)
For k = LBound(c) To UBound(c)
If A(j) = c(k) Then
Nb = Nb + 1: Exit For
End If
Next k
Next j
If Nb = UBound(A) + 1 Then
ReDim Preserve d(1 To l)
d(l) = b(i, 1) & "#" & b(i, 2)
'd(l, 1) = b(i, 2)
l = l + 1
End If
Nb = 0
Next i
End If
Next s
Dim e()
For i = LBound(d) To UBound(d)
ReDim Preserve e(1 To UBound(d))
e(i) = Split(d(i), "#")
Sheets("RésultatRecherche").Cells(i + 5, 1) = e(i)(0)
Sheets("RésultatRecherche").Cells(i + 5, 1).Hyperlinks.Add Anchor:=Sheets("RésultatRecherche").Cells(i + 5, 1), Address:="", SubAddress:= _
Sheets(e(i)(1)).Name & "!" & e(i)(2), TextToDisplay:=e(i)(0)
Next i
Exit Sub
Erreur:
MsgBox "chaîne de caractère inconnue"
End Sub
Function Sans_accents(Chaine As String) 'http://www.generation-nt.com/reponses/comment-remplacer-caractere-accentue-par-non-accentue-e-mails-entraide-3563901.html
Dim T As String, A As String, b As String
Dim i As Integer, U As String
If Chaine = "" Then Exit Function
T = Chaine
'remplacement des caractères accentués
A = "ÀÁÂÃÄÅÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåèéêëìíîïðñòóôõöùúûüýÿçÇ"
b = "AAAAAAEEEEIIIINOOOOOUUUUYaaaaaaeeeeiiiionooooouuuuyycC"
For i = 1 To Len(T)
U = InStr(1, A, Mid(T, i, 1), 0)
If U Then Mid(T, i, 1) = Mid(b, U, 1)
Next i
Sans_accents = T
End Function
Function Extractions(Texte As String, MonPattern As String, Optional Remplacement As String, Optional Inverse As Boolean) As String 'par JNP
Dim Match, Matches
If Inverse = False Then
With CreateObject("vbscript.regexp")
.Global = True: .Pattern = MonPattern
Extractions = Trim(.Replace(Texte, Remplacement))
End With
Else
With CreateObject("vbscript.regexp")
.Global = True: .Pattern = Replace(MonPattern, " ?", "")
Set Matches = .Execute(Texte)
For Each Match In Matches
Extractions = Extractions & " " & Match
Next
End With
Extractions = Trim(Extractions)
End If
End Function