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!