Microsoft 365 Trier une base de donnée par rapport à une colonne et l'envoie de mail auto

Const ColRes As Byte = 8
Sub Ext_Globale()

     Dim Wsh As Worksheet, WshG As Worksheet, _
         NbLgn As Long, NbCol As Long, Tb, LstEmetteur, Emetteur, TbRes, _
         OLk As Object, Chemin$, Adresse$, Objet$, Corps$, Semaine$
    
     Semaine = Format(WorksheetFunction.IsoWeekNum(Date - 7), "00")
     'chemin d'enregistrement des fichiers par émetteur (avec N° de la semaine précédente)
     Chemin = ThisWorkbook.Path & Application.PathSeparator & "Commandes émises S" & Semaine
     If Dir(Chemin, vbDirectory) = "" Then MkDir Chemin            'crée le sous-dossier

    
     Set Wsh = ThisWorkbook.Worksheets("Données")
     Set WshG = ThisWorkbook.Worksheets("Global")
    
     'Données brutes
     With Wsh
          NbLgn = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
          NbCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
          Tb = Wsh.Cells(2, 1).Resize(NbLgn, NbCol)
     End With
     'Données triées (fonction TRIER)
     Tb = WorksheetFunction.Sort(Tb, 1, 1)
    
     Application.ScreenUpdating = False
     'Copie dans la feuille Globale
     With WshG
          .ListObjects(1).Resize .ListObjects(1).HeaderRowRange.Resize(2)
          .Rows(2).Resize(.Rows.Count - 1).Clear
          .Cells(2, 1).Resize(NbLgn, ColRes).Value = Tb
          Tb = .Cells(2, 1).Resize(NbLgn, ColRes).Value
     End With
    
     'Liste des émetteurs
     With WorksheetFunction
          LstEmetteur = .Unique(.Index(Tb, 0, 1))
     End With
    
     'Préparation pour envoi par mail
     TbMail = ThisWorkbook.Worksheets("Table").[_Tb_Mail]
     Objet = "Suivi commandes émises S" & Semaine
     Corps = "Veuillez trouver ci-joint la liste des commandes émises semaine " & Semaine & Chr(10) & Cordialement
     Set OLk = CreateObject("Outlook.application")
    
     'Entête commune
     Set Entête = WshG.Rows(1).Resize(1, ColRes)
    
     'Tableau pour fitrer avec la fonction FILTRE
     ReDim Test(1 To NbLgn, 1 To 1)
    
     Application.DisplayAlerts = False
     For Each Emetteur In LstEmetteur
          'Préparation du Filtre pour la fonction FILTRE
          For i = 1 To NbLgn: Test(i, 1) = Tb(i, 1) = Emetteur: Next
          'Appel de la fonction FILTRE
          TbRes = WorksheetFunction.Filter(Tb, Test)
          'Supprimer la feuille "émetteur" si elle existe
          If FeuilleExiste(CStr(Emetteur)) Then ThisWorkbook.Worksheets(Emetteur).Delete
          
          'Nouvelle feuille émetteur
          Set Wsh = ThisWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
          With Wsh
               .Name = Emetteur
               Entête.Copy Destination:=.Cells(1)
               .Cells(2, 1).Resize(UBound(TbRes), ColRes) = TbRes
               .ListObjects.Add(xlSrcRange, .UsedRange, , xlYes).Name = "_Tb_" & Emetteur
               Entête.Copy
               .UsedRange.Rows(1).PasteSpecial Paste:=xlPasteColumnWidths
               'en faire un classeur séparé
               .Move
          End With
          'Sauvegarde dans le répertoire de la semaine et fermeture
          With ActiveSheet.Parent
               .SaveAs Chemin & Application.PathSeparator & Emetteur & ".xlsx", FileFormat:=xlOpenXMLWorkbook
               .Close
          End With
          
          'recherche de l'adresse mail de l'émetteur dans la table
          Adresse = ""
          On Error Resume Next
          Adresse = WorksheetFunction.VLookup(Emetteur, TbMail, 2, False)
          On Error GoTo 0
          'si l'adresse est trouvée envoi du fichier par OUTLOOK
          If Adresse <> "" Then
               With OLk.CreateItem(olMailItem)
                    .Subject = Objet
                    .To = Adresse
                    .Body = Corps
                    .Attachments.Add Chemin & Application.PathSeparator & Emetteur & ".xlsx"
                    .Send
               End With
          End If

     Next
     Application.DisplayAlerts = True
    
     OLk.Quit

End Sub

Function FeuilleExiste(Nom As String) As Boolean
     'Renvoie Vrai si la feuille "Nom" existe
     Dim Test
     On Error Resume Next
     Test = ThisWorkbook.Worksheets(Nom).Name
     On Error GoTo 0
     FeuilleExiste = Not IsEmpty(Test)
End Function