Création de plusieurs classeurs Excel
Bonjour,
je dois créer plusieurs fichiers suivant une base de donnée:
Colonne 1 Colonne 2 Colonne 3 Colonne 4
Fournisseur 1 ABC Commande 1 AZ
Fournisseur 1 ABC Commande 2 BY
Fournisseur 2 DEF Commande 3 AZ
Fournisseur 2 DEF Commande 4 AZ
Fournisseur 2 DEF Commande 5 BY
Fournisseur 3 GHI Commande 6 AZ
Suivant les données ci-dessus,
je dois créer des classeurs excel, avec comme onglet la colonne 4 (AZ ou/et BY)
et répéter sur ces onglets, les lignes concernées par fournisseur(colonne 1,2&3), ensuite j'ai besoin de l'enregistrer sous le nom de la colonne 1 et de la colonne 2 et en écrivant commande.
Et faire autant de fichier qu'il y a de fournisseur.
Est-ce possible de faire cette macro ?
Dans mon fichier, il y a plus de 1000 lignes avec 160 fournisseurs différents...
Merci pour votre aide.
Merci beaucoup, c'est ce qu'il me faut
après j'aurai besoin de créer des onglets sur chaque fichier,
par rapport à une colonne qui indique deux valeurs différentes.
Si tu veux aller plus loi, poste n fichier exemple avec des valeurs quelconques.
Bonjour,
j'aurai besoin en plus de la fragmentation, d'ajouter deux onglets ou un seul en fonction de la colonne F.
Et cette colonne F ne doit plus apparaître dans mes fichiers.
Chaque ligne concernée doit aller dans le bon onglet.
Bonjour,
Je suis reparti de zéro, ce qui m'a permis de réaliser un code plus rapide.
Et comme j'aime bien commencer par des choses plutôt généralisables, pas trop spécifiques, je suis parti sur :
- 1ère colonne : nom du fichier
- 2ème colonne : nom de l'onglet
Après on peut "customiser" ...
Option Explicit
Sub fractionner()
Dim Tbl As Variant, data As Variant, i%, prov As String
Dim dico1 As Object, cle1 As Variant, result1 As Variant, prov1 As String
Dim dico2 As Object, cle2 As Variant, result2 As Variant, prov2 As String
Dim xl As Excel.Application, wb As Excel.Workbook
Dim MonRepertoire, Repertoire As FileDialog
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
Repertoire.Show
If Repertoire.SelectedItems.Count = 0 Then Exit Sub
MonRepertoire = Repertoire.SelectedItems(1)
data = ActiveSheet.Cells(1, 1).CurrentRegion
prov1 = data(1, 1): prov2 = data(1, 2)
Set dico1 = CreateObject("Scripting.Dictionary")
For i = LBound(data) + 1 To UBound(data) ' hors en-tête
dico1(data(i, 1)) = dico1(data(i, 1)) & "|" & data(i, 2)
Next
Set dico2 = CreateObject("Scripting.Dictionary")
For Each cle1 In dico1.Keys
prov = dico1(cle1)
Tbl = Split(prov, "|")
dico2.RemoveAll
For i = LBound(Tbl) + 1 To UBound(Tbl)
prov = Tbl(i)
dico2(prov) = ""
Next
dico1(cle1) = ""
For Each cle2 In dico2.Keys
dico1(cle1) = dico1(cle1) & "|" & cle2
Next
Next
Set xl = CreateObject("Excel.Application")
xl.SheetsInNewWorkbook = 1
For Each cle1 In dico1.Keys
Set wb = xl.Workbooks.Add
xl.Visible = True
Tbl = Split(dico1(cle1), "|")
For i = LBound(Tbl) + 1 To UBound(Tbl) ' hors premier car la chaîne commence par le séparateur
data(1, 1) = cle1: data(1, 2) = Tbl(i)
result1 = FiltreArrayLignes(data, 1, cle1): result1(1, 1) = prov1
result2 = FiltreArrayLignes(result1, 2, Tbl(i)): result2(1, 2) = prov2
With wb.Worksheets.Add
.Cells(1, 1).Resize(UBound(result2, 1), UBound(result2, 2)) = result2
.Name = Tbl(i)
.Columns("A:B").Delete Shift:=xlToLeft
End With
Next
wb.SaveAs (MonRepertoire & "\" & cle1 & ".xlsx")
wb.Close
Set wb = Nothing
Next
xl.Quit
Set xl = Nothing
MsgBox "Terminé !"
End Sub
Function FiltreArrayLignes(Tbl, col, cle)
Dim i%, n%
' J. Boisgontier
' ne fonctionne pas si une seule occurence
Dim tmp(): ReDim tmp(1 To UBound(Tbl))
For i = LBound(Tbl) To UBound(Tbl)
If Tbl(i, col) = cle Then n = n + 1: tmp(n) = i
Next
ReDim Preserve tmp(1 To n)
FiltreArrayLignes = Application.Index(Tbl, Application.Transpose(tmp), _
Application.Transpose(Evaluate("Row(1:" & UBound(Tbl, 2) & ")")))
End Function