XL 2019 table des matières

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