Microsoft 365 Filtrer dans une variable-tableau : possible ?

Option Explicit
    Dim topD As Date, topF As Date
    Dim TabBDD As Variant, Tab_Resultat As Variant
    Dim Tab_Temp() As Variant, TabInit As Variant
    Dim Lgn As Long, NbLignes As Long
    Dim Service As String
    Dim Col As Long
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Application.ScreenUpdating = False
    With Sheets("Pannes")
        If Sh.Name = .Name Then Exit Sub
          ' Démarrer le chronomètre
        topD = Time
        TabInit = .ListObjects(1).DataBodyRange.Value 'on récupére le Tableau a l'origine
                         ' Trier par  "Service" (ascendant)
             With .ListObjects(1).Sort  'On va trier le Tableau en fonction des Valeurs des Colonnes « Date » et « Arrivée »du Tableau Structuré
                      With .SortFields
                             .Clear
                             .Add2 Key:=Range("t_Pannes").ListObject.ListColumns("Service").DataBodyRange, _
                          SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                      End With 'SortFields
                             .Header = xlYes ' Le tableau contient des en-têtes
                             .Apply
             End With 'Sort
        ' Charger la base de données Triée en mémoire
        TabBDD = .ListObjects(1).DataBodyRange.Value
        NbLignes = UBound(TabBDD, 1) 'On définit le Nombre de Ligne du tableau
        ' Initialiser le service à rechercher
        Service = UCase(Replace(Sh.Name, "é", "e"))
        ' Créer un tableau dynamique sans ReDim Preserve (meilleure performance)
        Dim TmpArr() As Variant
        Dim NbMatches As Long
        ReDim TmpArr(1 To NbLignes, 1 To UBound(TabBDD, 2)) ' Taille max possible
        ' Filtrer les lignes et les stocker dans TmpArr
                           NbMatches = 0
        For Lgn = 1 To NbLignes
            If TabBDD(Lgn, 8) = Service Then ' Si le service correspond
                NbMatches = NbMatches + 1
                ' Copier la ligne entière manuellement
                For Col = 1 To UBound(TabBDD, 2)
                    TmpArr(NbMatches, Col) = TabBDD(Lgn, Col)
                Next Col
            End If
        Next Lgn
        ' Si des données ont été trouvées, on réduit la taille du tableau
        If NbMatches > 0 Then
            ReDim Tab_Temp(1 To NbMatches, 1 To UBound(TabBDD, 2))
            For Lgn = 1 To NbMatches
                For Col = 1 To UBound(TabBDD, 2)
                    Tab_Temp(Lgn, Col) = TmpArr(Lgn, Col)
                Next Col
            Next Lgn
            ' Supprimer les anciennes données de la feuille Cible
            If Not Sh.ListObjects(1).DataBodyRange Is Nothing Then
                     Sh.ListObjects(1).DataBodyRange.Delete xlUp
            End If
            ' Insérer les nouvelles données
            Sh.ListObjects(1).Range.Cells(1, 1).Offset(1, 0).Resize(UBound(Tab_Temp, 1), UBound(Tab_Temp, 2)) = Tab_Temp
        End If
               topF = Time
        MsgBox "Le traitement a duré " & Format(topF - topD, "HH:MM:SS")
    End With
    With Sheets("Pannes").ListObjects(1) 'On va remettre les données comme elles etaient au Départ
       .DataBodyRange.Cells(1, 1).Resize(UBound(TabInit, 1), UBound(TabInit, 2)) = TabInit
    End With
 ' Réactiver l'affichage et afficher la durée du traitement
        Application.ScreenUpdating = True
    Set TabInit = Nothing: Erase Tab_Temp: NbMatches = 0:Set Sh= Nothing
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim critere$, h&, P As Range
critere = Replace(Sh.Name, "é", "e")
Application.ScreenUpdating = False
With Sheets("Pannes")
    If Sh.Name = .Name Then Exit Sub
    With .ListObjects(1).Range
        .AutoFilter: .AutoFilter 'affiche tout
        .Columns(8).EntireColumn.Insert 'colonne auxiliaire
        .Cells(2, 8) = 1: .Cells(2, 8).Resize(.Rows.Count - 1).DataSeries 'numérotation
        .Sort .Columns(9), Header:=xlYes 'tri pour regrouper
        h = Application.CountIf(.Columns(9), critere)
        If h Then Set P = .Rows(Application.Match(critere, .Columns(9), 0)).Resize(h)
    End With
    With Sh.ListObjects(1).Range
        .AutoFilter: .AutoFilter 'affiche tout
        If Not .ListObject.DataBodyRange Is Nothing Then .ListObject.DataBodyRange.Delete xlUp
        If h Then .Columns(8).EntireColumn.Insert: P.Copy .Cells(2, 1): .Columns(8).EntireColumn.Delete
    End With
    With .ListObjects(1).Range
        .Sort .Columns(8), xlAscending, Header:=xlYes 'retour à l'ordre initial
        .Columns(8).EntireColumn.Delete 'supprime la colonne auxiliaire
    End With
End With
End Sub

With .ListObjects(1).Range
        .Sort .Columns(8), xlAscending, Header:=xlYes 'retour à l'ordre initial

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim lsto As ListObject, topD#, ref$, nref&, ncol&, nlig&, n&, i&, j&, xrg1 As Range, xrg2 As Range
   topD = Timer                                                         ' timer début
   Application.ScreenUpdating = False                                   ' on fige l'écran
   If LCase(Sh.Name) = LCase("Pannes") Then Exit Sub                    ' si c'est la feuille "Pannes", on quitte
   ref = Sh.Name                                                        ' la référence à garder
   nref = Sheets("Pannes").ListObjects(1).ListColumns("Service").Index  ' index de la colonne "Service"
   ncol = Sheets("Pannes").ListObjects(1).ListColumns.Count             ' nbre colonnes de la source
   nlig = Sheets("Pannes").ListObjects(1).ListRows.Count + 1            ' nbre lignes de la source
   Columns("a").CurrentRegion.EntireColumn.Clear                        ' effacement du précédent résultat
   [a1].Resize(nlig, ncol).Value2 = Sheets("Pannes").ListObjects(1).Range.Value2          ' copie de la source vers la feuille cible
   [a1].CurrentRegion.Sort Cells(1, ncol), xlAscending, Header:=xlYes, MatchCase:=False   ' tri
   ' première cellule égale à ref
   Set xrg1 = Columns(ncol).Find(what:=ref, LookIn:=xlValues, lookat:=xlWhole, After:=Cells(1, ncol), searchdirection:=xlNext, MatchCase:=False)
   If Not xrg1 Is Nothing Then
      ' dernière cellule égale à ref
      Set xrg2 = Columns(ncol).Find(what:=ref, LookIn:=xlValues, lookat:=xlWhole, After:=Cells(1, ncol), searchdirection:=xlPrevious, MatchCase:=False)
      Range(Cells(xrg2.Row + 1, 1), Cells(nlig + 1, ncol)).Delete shift:=xlShiftUp            ' suppression des lignes après
      If xrg1.Row > 2 Then Range(Cells(2, 1), Cells(xrg1.Row - 1, ncol)).Delete shift:=xlShiftUp   ' suppression des lignes avant
      Set lsto = ActiveSheet.ListObjects.Add(xlSrcRange, [a1].CurrentRegion, , xlYes)              ' plage en tableau structuré
      lsto.Name = ref                                                                              ' nom du TS
      MsgBox "Pour le critère <" & ref & "> : " & Format(lsto.ListRows.Count, "#,##0\ lignes copiées  en ") & _
            Format(Timer - topD, "0.00\ sec.")
   Else
      Range(Cells(1, 1), Cells(Rows.Count - 1, ncol)).Delete shift:=xlShiftUp    ' pas de ligne avec ref -> on efface tout
      MsgBox "Pour le critère <" & ref & "> : aucune ligne copié en " & Format(Timer - topD, "0.00\ sec.")
   End If
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim critere$, h&, P As Range
critere = Replace(Sh.Name, "é", "e")
Application.ScreenUpdating = False
With Sheets("Pannes")
    If Sh.Name = .Name Then Exit Sub
    .Copy 'document auxiliaire
End With
With ActiveWorkbook.Sheets(1).ListObjects(1).Range
    .AutoFilter: .AutoFilter 'affiche tout
    .Sort .Columns(8), Header:=xlYes 'tri pour regrouper
    h = Application.CountIf(.Columns(8), critere)
    If h Then Set P = .Rows(Application.Match(critere, .Columns(8), 0)).Resize(h)
End With
With Sh.ListObjects(1).Range
    .AutoFilter: .AutoFilter 'affiche tout
    If Not .ListObject.DataBodyRange Is Nothing Then .ListObject.DataBodyRange.Delete xlUp
    .Columns(8).EntireColumn.Insert: .Columns(8).EntireColumn.Delete 'nécessaire si la ligne Total est affichée
    If h Then P.Copy .Cells(2, 1)
End With
ActiveWorkbook.Close False 'ferme le document auxiliaire
End Sub

Sub test()
    Dim x, Arr()
    With Sheets("Pannes").Cells(1).CurrentRegion
        x = Filter(.Parent.Evaluate("transpose(if((" & .Columns(8).Address & "=""FABRICATION""),row(1:" & .Rows.Count & ")))"), False, 0)
        If UBound(x) = -1 Then Exit Sub
        Arr = Application.Index(.Value2, Application.Transpose(x) _
                                        , Evaluate("column(" & .Rows(1).Address & ")"))
        'Arr = Application.Index(.Value2, Application.Transpose(x), Evaluate("column(a:h)"))
        If UBound(x) = 0 Then
            Sheets("Fabrication").[A2].Resize(, UBound(Arr)) = Arr
        Else
            Sheets("Fabrication").[A2].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
        End If
        Sheets("Fabrication").Cells(1).CurrentRegion.Columns(1).NumberFormat = "m/d/yyyy"
    End With
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim critere$, tablo, ub%, rfesu(), i&, n&, j%, dbrc&, total As Boolean
critere = UCase(Replace(Sh.Name, "é", "e")) 'si toute la colonne 8 est en majuscules
With Sheets("Pannes")
    If Sh.Name = .Name Then Exit Sub
    tablo = .ListObjects(1).Range 'matrice, plus rapide
End With
ub = UBound(tablo, 2)
ReDim resu(1 To UBound(tablo), 1 To ub)
For i = 1 To UBound(tablo)
    If tablo(i, 8) = critere Then
        n = n + 1
        For j = 1 To ub: resu(n, j) = tablo(i, j): Next j
    End If
Next i
Application.ScreenUpdating = False
With Sh.ListObjects(1)
    If Not .DataBodyRange Is Nothing Then dbrc = .DataBodyRange.Rows.Count
    total = .ShowTotals: .ShowTotals = False 'ôte la ligne Total
    With .Range
        .AutoFilter: .AutoFilter 'affiche tout
        .Cells(2, 1).Resize(n, ub) = resu 'restitution
        If n < dbrc Then .Rows(n + 2).Resize(dbrc - n).Delete xlUp 'lignes excédentaires
    End With
    .ShowTotals = total 'état initial
End With
End Sub