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

[JoeZ1]

Hello à tous,

J'espère que vous allez tous bien.

J'ai besoin de vos compétences pour créer un fichier Excel.
J'ai cherché sur internet et je n'ai rien trouvé qui correspond à mon besoin

Tous les lundi matin, je fais une extraction Excel dans un logiciel.

Je supprime des colonnes, je crée des onglets par Emetteur et puis j'envois l'onglet concerné à l'émetteur concerné.

Ma question est:

Est il possible de faire un tri de l'onglet "donnée". Mon tri doit être fait par le nom de l'émetteur.
Chaque émetteur doit avoir son propre onglet.
Et j'ai besoin aussi d'avoir une vision globale des émetteurs
Et les onglets "emetteurs" doit ressembler à l'onglet "global"

Et en abusant, est il possible d'envoyer les mails automatiquement de chaque onglets des émetteurs?

Dans ma tête c'est très clair mais à expliquer mon problème. Ce n'est pas évident

Je vous remercie par avance pour votre aide, vous allez me faire gagner beaucoup de temps.

@+

 

[AtTheOne]

Bonjour à toutes & à tous, bonjour @JoeZ1
Dans le fichier joint j'ai traité ton problème avec les fonctionnalités de MS365 (ou office 2021) :
Fonctions TRIER, UNIQUE, et FILTRE en tant que WorksheetFunction.

Comme tu dois envoyer individuellement leurs données à chaque émetteur, j'ai choisi d'enregistrer ces données dans des fichiers séparés dans un sous-répertoire "Commandes émises Sxx" du répertoire contenant le fichier global (xx étant le N° de la semaine précédant la date d'envoi, un lundi si j'ai bien compris)

L'envoi par mail se fait par OUTLOOK, comme tu es sur MS365 cela ne doit pas poser de problème.
Tu dois d'abord renseigner les adresses mail de tes émetteurs dans l'onglet Table, (si l'adresse d'un émetteur manque, la macro ne tente pas l'envoi.)

Voilà teste le fichier joint en mettant ton adresse pour tous les émetteurs, comme j'ai fait ...
Bon courage
Amicalement
Alain

Modif : le Code
Macro principale :

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

Fonction FeuilleExiste :

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

 

[JoeZ1]

Hello,

Un GRAND merci.
C'est exactement ce que je souhaitais et il fonctionne très bien

Parfait

 

[AtTheOne]

Bonsoir @JoeZ1
Merci de ton retour, si c'est bien le cas, tu peux marquer le post 2 comme étant la solution.
Amicalement
Alain