Sub CreerClasseursFournisseurs()
Dim Plg_Datas As Range ' Plage de cellules du tableau 'BaseArticles'
Dim Lst_Fournisseurs As Variant ' Liste des noms uniques de fournisseurs
Dim i As Integer ' variable de compteur de boucle for
Dim NomFichier As String ' nom du nouveau fichier
'
' Feuilles de travail (dans ce classeur)
Dim shParams As Worksheet, shTemp As Worksheet
'
' Récupérer la liste des fournisseurs
Lst_Fournisseurs = ListeFournisseurs()
'
' si elle est vide, avertir l'utilisateur et sortir
If IsEmpty(Lst_Fournisseurs) Then
MsgBox "Opération interrompue : " & vbCrLf & "Aucun fournisseur dans la liste!", vbExclamation, "Création classeurs fournisseurs"
Exit Sub
End If
'
' Initialisation des variables objets de ce classeur
With ThisWorkbook
Set shParams = .Sheets("Params") ' Feuille sur laquelle se trouve la zone de critères d'extraction
Set shTemp = .Sheets("Temp") ' feuille temporaire qui contiendra les données extraites
Set Plg_Datas = .Sheets("Base").ListObjects("BaseArticles").Range ' plage source des données à extraire
End With
'
'
AppOFF
'
' Parcourir la liste des fournisseurs
For i = 0 To UBound(Lst_Fournisseurs)
'
' Préparation des critères d'extraction
shParams.Range("A2") = Lst_Fournisseurs(i)
'
' Suppression d'éventuelle données précédentes
shTemp.Range("A1").CurrentRegion.EntireRow.Delete
'
' Extraction des données, copie dans la feuille temporaire
Plg_Datas.AdvancedFilter xlFilterCopy, shParams.Range("A1:A2"), shTemp.Range("A1")
'
' .Copy sans argument, copiera la feuille Temp dans un nouveau classeur
' ils deviendront les objets workbook et worksheet actif
shTemp.Copy
'
' Travailler à partir de la feuille active du nouveau classeur
With ActiveSheet
'
' Lui donner un nom
.Name = "Données"
'
' Créer le tableau structuré des données
.ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = "T_Données"
'
' Enregistre le parent de la feuille qui est le nouveau classeur
With .Parent
'
' Nom du fichier à partir de la liste fournisseurs
NomFichier = ThisWorkbook.Path & "\" & Lst_Fournisseurs(i) & ".xlsx"
'
' s'il existe déjà on le supprime
If Dir(NomFichier) <> "" Then Kill NomFichier
'
' sauvegarde et le fermeture
.SaveAs NomFichier, xlOpenXMLWorkbook
.Close
End With
End With
'
' Fin traitement du fournisseur en cours, on passe au suivant
Next i
AppOn
End Sub
