XL 2016 Scinder fichiers Excel en plusieurs fichiers

[clem312]

Bonjour,

Je cherche à scinder un fichier Excel en plusieurs fichiers.
Sur le forum j'ai trouvé cette super macro de @mapomme
Par contre, cette macro réplique la 1ère ligne du fichier initiale dans chaque fichier généré.
J'ai besoin que la macro ne réplique pas la 1ère colonne mais je n'y arrive pas

Clément

 

[Robert]

Bonsoir Clem, bonsoir le forum,

Si je n'avions pas mélangé trop mes pinceaux ça devrait donner :

Sub découper()
Dim derlig&, dercol&, prefixe, nom$, n&, nbfic&
Dim F1, F2, i&, i1&, i2&, newclas, first

Application.ScreenUpdating = False
Set F1 = ThisWorkbook.Sheets("Feuil1")
Set F2 = ThisWorkbook.Sheets("Feuil2")
With F2
    derlig = .Cells(.Rows.Count, "a").End(xlUp).Row
    dercol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    nbfic = (derlig - 1) \ F1.Range("b3") - ((((derlig - 1) Mod F1.Range("b3"))) > 0)
End With
With F1
    prefixe = ThisWorkbook.Path
    If Right(prefixe, 1) <> "\" Then prefixe = prefixe & "\"
    prefixe = prefixe & .Range("b1")
    On Error Resume Next: MkDir prefixe: On Error GoTo 0
    If Right(prefixe, 1) <> "\" Then prefixe = prefixe & "\"
    prefixe = prefixe & .Range("b2")
    prefixe = prefixe & "-"
End With

With F2
    i1 = 2: i2 = i1 + F1.Range("b3") - 1
    Set newclas = Workbooks.Add
    Do
        '.Range("a1").Resize(, dercol).Copy newclas.Sheets(1).Range("a1")
        .Range(.Cells(i1, "a"), .Cells(i2, dercol)).Copy newclas.Sheets(1).Range("a1")
        newclas.Sheets(1).Range("a1").Resize(, dercol).EntireColumn.AutoFit
        Application.DisplayAlerts = False
        n = n + 1
        Application.StatusBar = "fichier n° " & n & " / " & nbfic
        nom = prefixe & Left("0000", 4 - Len("" & n)) & n & ".xlsx"
        newclas.SaveAs Filename:=nom, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        Application.DisplayAlerts = True
        If IsEmpty(first) Then first = nom
        i1 = i1 + F1.Range("b3"): i2 = i2 + F1.Range("b3")
        If i1 > derlig Then Exit Do
        newclas.Sheets(1).UsedRange.Clear
    Loop
End With
newclas.Close SaveChanges:=False
Application.StatusBar = False
MsgBox "Création de " & n & " fichiers terminée !" & vbLf & vbLf & _
"depuis  " & vbLf & first & vbLf & vbLf & _
"jusqu'à " & vbLf & nom, vbInformation
End Sub

 

[clem312]

Bonsoir @Robert ,

Merci de votre aide.
C'es quasiment ca ! Nickel pour la 1ere ligne. Par contre la colonne B n'est pas copiée et on perd la hauteur et largeur des cellules ce qui n'était pas le cas dans le script initial.
Une idée ?

Clément

 

[Robert]

Re,

Très étonné car je n'ai fait que supprimer le copier/coller de la première ligne. Je ne vois pas en quoi cela influencerait sur la hauteur et la largeur des cellules et sur le fait de ne pas copier la colonne B... Mais j'avoue que je n'ai pas testé. La flemme...

 

[clem312]

Re,

Très étonné car je n'ai fait que supprimer le copier/coller de la première ligne. Je ne vois pas en quoi cela influencerait sur la hauteur et la largeur des cellules et sur le fait de ne pas copier la colonne B... Mais j'avoue que je n'ai pas testé. La flemme...

Bonjour @Robert

Ah oui, au temps pour moi. J'ai passé la macro sur un fichier ou il y a des cellules fusionnés et les colonnes après la 1ere sautent...
Je mets le fichier en PJ si vous avez une idée.

Clément

 

[Robert]

Re,

VBA et les cellules fusionnées ne sont pas très amis... La macro na pas été créée pour ce type de données et je t'avoue que j'ai la flemme de m'y pencher dessus... Désolé.