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

[MickaelKeul]

Apres l'import ... l'export !

J'ai un fichier avec un tableau structuré qui contient des données de plusieurs fournisseurs. Je cherche a créer plusieurs nouveau fichier (1 par fournisseur) qui reprend unique les données correspondant a chaque fournisseurs.
Le code VBA que j'ai fait arrive a filtrer et créer chaque fichier mais le problème c'est que ça me copie ces nouveaux fichiers l'intégralité des données ...
Je sèche car je pensais (et lu) que "DataBodyRange" ne sélectionnait que les données filtrées

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

 

[Dranreb]

Bonsoir.
Essayez en ajoutant .SpecialCells(xlCellTypeVisible) derrière DataBodyRange

 

[MickaelKeul]

Ca marche parfaitement ! merci !!