Découper un fichier en plusieurs fichiers

Bonjour à tous,

Je suis un débutant en macro,

Je viens de passer un long moment pour essayer de ne pas vous embêter en trouvant une macro qui existe déjà, mais je n'arrive pas à l'adapter.

Voici mon problème,

Tous les lundis j'ai un fichier d'extraction avec différents produits à livrer par fournisseurs. Aujourd'hui je passe des heures à créer manuellement des fichiers découpés par fournisseurs en copier coller.

Je souhaiterai avoir automatiquement un fichier par fournisseur (Colonne E) qui reprenne exactement la même trame que le fichier de base. Les nouveaux fichiers auraient le nom du fournisseur et seraient sauvegardés au même endroit. Tous les lundis, l'extraction est refaite, et tous les fichiers sont modifiés/remplacés intégralement.

D'avance merci si qqn a le temps de se pencher sur ce problème qui me rend fou!

Si je ne suis pas clair, n'hésitez pas!!

Merci!!!!

Bonjour Thomnulexcel , bonjour à tous

Voilà une macro qui fait le travail...je n'ai pas eu le temps d"étudier le cas où les classeurs existeraient déjà...je m'y pencherai lorsque j'aurai le temps.

Sub Crea_classeurs()
Dim F As Worksheet
Dim NewClasseur As Workbook
Dim Tabl()
    Set F = Worksheets("Sheet0")
    derlig = F.Range("A" & Rows.Count).End(xlUp).Row
    ReDim Tabl(derlig)
    ITab = 0
    Tabl(ITab) = F.Range("E" & 2).Value
Suivant:
    If i = derlig Then GoTo Suite
    For i = 3 To derlig
        For j = LBound(Tabl) To UBound(Tabl)
            If Tabl(j) = F.Range("E" & i).Value Then 'Si valeur trouvée
                GoTo Suivant
            End If
        Next
        ITab = ITab + 1
        Tabl(ITab) = F.Range("E" & i).Value
    Next
Suite:
    Application.ScreenUpdating = False
    Chemin = ActiveWorkbook.Path
    Set Ws = ActiveSheet
'new
    For j = LBound(Tabl) To UBound(Tabl)
        If Tabl(j) = "" Then GoTo Fini
        Set NewClasseur = Application.Workbooks.Add
        NewClasseur.SaveAs Filename:=Chemin & "\" & Tabl(j)
        Windows(Tabl(j) & ".xlsx").Activate
        Ws.Range("A1:Z1").Copy Destination:=Range("A1:Z1")
        LNew = 2
        For i = 2 To derlig
            If Ws.Range("E" & i).Value = Tabl(j) Then
                Ws.Range("A" & i & ":Z" & i).Copy Destination:=Range("A" & LNew & ":Z" & LNew)
                LNew = LNew + 1
            End If
        Next
'ajuster les colonnes
        Columns("A:Z").AutoFit
        ActiveWorkbook.Close
    Next
Fini:
    Application.ScreenUpdating = True
    MsgBox "Création classeurs terminé"
End Sub

Bon courage...

merci infiniment, je teste ça de suite!