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.

Bonjour et bienvenue,

un outil qui peut t'aider

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.

5commande.xlsx (9.35 Ko)

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
Rechercher des sujets similaires à "creation classeurs"