Option Base 1
Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
'Sortir si La modif ne provient pas du mot clef
If Intersect(Target, [_Mot_Clef]) Is Nothing Then Exit Sub
Dim Tb, MotClef$, Extrait(), Article, Nb_Articles As Long, i As Long
'RàZ de l'extraction
[_Extraction].ClearContents
With Me.ListObjects("_Extraction")
.Resize .HeaderRowRange.Resize(2)
End With
MotClef = [_Mot_Clef]
'Sortir si le mot clef est vide
If MotClef = "" Then Exit Sub
'Liste des articles
TbAll = Worksheets("Table des Matières").ListObjects("_Tdm").DataBodyRange.Value
Tb = Worksheets("Table des Matières").[_TdM[Article / Sujet]]
Tb_Lien = Worksheets("Table des Matières").[_TdM[Magazines]].FormulaR1C1
For i = 1 To UBound(Tb)
TbAll(i, 5) = Tb_Lien(i, 1)
Next i
'Recherche des articles qui correspondent
Nb_Articles = 0
i = 0
For Each Article In Tb
i = i + 1
If sansaccent(CStr(Article)) Like "*" & sansaccent(MotClef) & "*" Then
Nb_Articles = Nb_Articles + 1
ReDim Preserve Extrait(Nb_Articles)
Extrait(Nb_Articles) = i
End If
Next
'Restitution du résultat de la recherche
If Nb_Articles > 0 Then
ReDim Tb_Res(1 To Nb_Articles, 1 To 9)
For i = 1 To Nb_Articles: For j = 1 To 9
Tb_Res(i, j) = TbAll(Extrait(i), j)
Next j: Next i
With Me.ListObjects("_Extraction")
.Resize .HeaderRowRange.Resize(Nb_Articles + 1)
.Range.Offset(1).Resize(Nb_Articles).FormulaR1C1 = Tb_Res
End With
End If
End Sub