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