MickaelKeul
XLDnaute Nouveau
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
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