Modifier VBA pour scinder fichier en plusieurs onglets dans un seul fichier...

[faber]

Bjr ,

j'ai récupéré de @mapomme du VBA (qui fonctionne à merveille) mais qui génère plusieurs classeurs.

Je voudrai que le fichier soit scindé dans 1 Classeur sur plusieurs Onglets

D'avance merci pour la modification du code (que je suis incapable de faire) 😀 !!!

le code est ci -dessous :

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("a2")
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