XL 2016 VBA exporter d'un tableau structuré vers plusieurs nouveau classeurs

Private Sub Exporter()

' **********************************
' Exporter les négos Fournisseurs
' **********************************

Dim Unique As Object
Dim DerLigne As Integer, DerColonne As Integer
Dim Plage As Range, c As Range
Dim Valeur


Set Unique = CreateObject("Scripting.Dictionary")


For Each c In Feuil1.ListObjects("BaseArticles").ListColumns("Fournisseur").DataBodyRange

If Not Unique.Exists(c.Value) Then Unique.Add c.Value, c.Value

Next c

For Each Valeur In Unique.keys

Feuil1.ListObjects("BaseArticles").Range.AutoFilter Field:=2, Criteria1:=Valeur

Workbooks.Add
Application.Dialogs.Item(xlDialogSaveAs).Show Valeur & "_OK"

Feuil1.ListObjects("baseArticles").HeaderRowRange.Copy [a1]
Feuil1.ListObjects("baseArticles").DataBodyRange.Copy [a2]


' Masque des colonnes
Range("a:c").EntireColumn.Hidden = True


' test protection cellules
ActiveSheet.Unprotect
Range("a1:ab2000").Locked = False
Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).row, 22)).Select
Selection.Locked = True

ActiveSheet.Protect 1234

ActiveWorkbook.Save

ThisWorkbook.Activate
Next


End Sub

Cliquez pour agrandir...