XL 2016 Filtre automatiquement avec VBA excel et powerpoint

'Macro de mise à jour de la liste des CodeSTART dans l'onglet "Tables"
Sub MàJ_Liste_CodeSTART()
   
     'Mise à jour de la liste des "CodeSTART"
   
     Dim tablo, DC As Object
   
     'RàZ du tableau
     With sh_Tables.[tb_CodeSTART]
          .Offset(1, 0).ClearContents
          .ListObject.Resize .ListObject.Range.Resize(2)
          .Cells(1).ClearContents
     End With
   
     'Liste des "CodeSTART"
     Set DC = CreateObject("Scripting.Dictionary")
     tablo = [tb_Eval[Code START]].Value2
     For i = 1 To UBound(tablo, 1)
          DC(tablo(i, 1)) = ""
     Next
   
     'Affectation de la liste au tableau
     sh_Tables.[tb_CodeSTART[Code START]].Resize(DC.Count, 1).Value2 = WorksheetFunction.Transpose(DC.keys)
   
     'Tri dans l'ordre croissant
     With sh_Tables.[tb_CodeSTART].ListObject
          .Sort.SortFields.Clear
          .Sort.SortFields _
               .Add2 Key:=[tb_CodeSTART[Code START]], SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
          .Sort.Header = xlYes
          .Sort.MatchCase = False
          .Sort.Orientation = xlTopToBottom
          .Sort.Apply
     End With
   
End Sub

Public Prés As Presentation, Sld As Slide

Sub NommerDiapo()
 
     Nb = Application.Presentations.Count
     If Nb > 2 Then
          MsgBox "Fermez d'abord les autres présentations !" & Chr(10) & "il y a " & Nb & " présentations ouvertes"
          Exit Sub
     End If
     Set Prés = Application.Presentations(MaPrésentation)
   
     Prés.Windows(1).ViewType = ppViewSlide
   
     For Each Sld In ActivePresentation.Slides
          Sld.Select
          Nom = Sld.Name
          With UsF_Nommage
               .Lbl_Nom.Caption = Nom
               .Show
          End With
     Next

End Sub

Private Sub UserForm_Initialize()
     Me.Left = 0
     Me.Top = 0
     Me.TBx_Nom.Text = ""
End Sub

Private Sub CBn_Valider_Click()
     Dim Dc As Object, Diapo As Slide
     If Me.TBx_Nom.Text <> "" Then
         
          'Collecte des noms des diapositives de la présentation dans le dictionnaire Dc
          'comme on change les noms il faut mettre à jour le dictionnaire à chaque diapo !
          Set Dc = CreateObject("Scripting.Dictionary")
          For Each Diapo In Prés.Slides
               Dc(UCase(Diapo.Name)) = ""
          Next
          If Dc.exists(UCase(Me.TBx_Nom.Text)) And UCase(Sld.Name) <> UCase(Me.TBx_Nom.Text) Then
               MsgBox "Ce nom de diapositive existe déjà dans la présentation !"
               With Me.TBx_Nom
                    .SetFocus
                    .SelStart = 0
                    .SelLength = .TextLength
               End With
               Exit Sub
          Else
               Sld.Name = Me.TBx_Nom.Text
               Unload Me
          End If
         
     End If
End Sub


Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
     If CloseMode = 0 Then
          MsgBox "Abandon pour cette diapositive !"
          Me.TBx_Nom.Text = ""
     End If
End Sub

'=========================================================
'Constante à adapter en fonction du nom de ta présentation
'=========================================================
Public Const NomFichPPT$ = "ppt5E35 testé.pptm"

'Mise à jour des moyennes par CodeSTART dans le diaporama

Sub MàJ_PPT()
    
     ' Late Binding
     Dim AppPPT As Object, Prés As Object, Diapo As Object, Shp As Object
     Dim DC As Object
     Dim MaPrésentation As String

     'mise à jour de la liste des "CodeSTART" avec les moyennes
     MàJ_Liste_CodeSTART
    
     Set AppPPT = CreateObject("PowerPoint.Application")
     Set DC = CreateObject("Scripting.Dictionary")
    
     'lecture des codeSTART avec les moyennes
     tablo = [tb_CodeSTART].Value2
     For i = 1 To UBound(tablo, 1)
          DC(tablo(i, 1)) = tablo(i, 2)
     Next
    
     'Accès à la présentation :
     MaPrésentation = ThisWorkbook.Path & "\" & NomFichPPT
    
     ' Vérification si le fichier existe
     If Dir(MaPrésentation) = "" Then
         MsgBox "Le fichier de présentation spécifié n'existe pas: " & MaPrésentation, vbCritical
         Exit Sub
     End If
     ' Vérification s'il est déjà ouvert
     Set Prés = Nothing
     On Error Resume Next
          Set Prés = AppPPT.Presentations(MaPrésentation)
     On Error GoTo 0
    
     On Error GoTo ErrHandler
     If Prés Is Nothing Then
          Set Prés = AppPPT.Presentations.Open(MaPrésentation)
     End If
     On Error GoTo 0
    
     AppPPT.Visible = msoCTrue
    
     'Boucle sur toutes les diapositives de la présentation
     For Each Diapo In Prés.Slides
          Nom = Diapo.Name                             'Nom de la diapo
          If DC.Exists(Nom) Then                       'Est-ce-que ce nom est l'un de "CodeSTART"
               On Error Resume Next
               Diapo.Shapes("Moy_" & Nom).TextFrame.TextRange.Text = Format(DC(Nom), "0.0")   'Si la forme moyenne du CodeSTAR existe on écrit la moyenne
               On Error GoTo 0
          End If
     Next
     Set AppPPT = Nothing
     Set Prés = Nothing
     Set Diapo = Nothing
     Set DC = Nothing
     Exit Sub

ErrHandler:
     MsgBox "Une erreur est survenue lors de l'ouverture de la présentation: " & Err.Description, vbCritical
     On Error Resume Next
     AppPPT.Quit
     Set AppPPT = Nothing
     Set Prés = Nothing
     Set Diapo = Nothing
     Set DC = Nothing

End Sub