Sub filtrer()
Dim A, c, reponse As String, i&, j&, k&, l&, Nb&, Pl As Range
On Error GoTo Erreur
Sheets("RésultatRecherche").Range("A6:A100").ClearContents
With Sheets("REGQSA")
Set Pl = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
reponse = InputBox("Texte ou expression à rechercher")
reponse = Sans_accents(reponse)
A = Split(reponse, ",")
Dim B(), d()
ReDim B(1 To Pl.Rows.Count, 1)
For i = 1 To Pl.Rows.Count
B(i, 0) = Replace(Sans_accents(Pl(i)), ",", "")
B(i, 1) = Pl(i)
Next i
l = 1
For i = LBound(B) To Pl.Rows.Count
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): l = l + 1
End If
Nb = 0
Next i
Sheets("RésultatRecherche").Range("A6").Resize(UBound(d)) = Application.Transpose(d)
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