Option Explicit
Sub test()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Copy
Next ws
End Sub
Option Explicit
Sub test()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Copy
ActiveWorkbook.SaveAs ActiveSheet.Name
Next ws
End Sub
Sub CreerFichiers()
Dim chemin$, w As Workbook, s As Object
chemin = ThisWorkbook.Path & "\" 'à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
'---fermeture des fichiers ouverts---
For Each w In Workbooks
If w.Name <> ThisWorkbook.Name Then w.Close
Next
'---création des fichiers---
For Each s In Sheets
ThisWorkbook.SaveAs chemin & s.Name, ThisWorkbook.FileFormat
Next
'---supression des feuilles---
For Each w In Workbooks
For Each s In w.Sheets
If Not w.Name Like s.Name & ".xls*" Then s.Delete
Next
w.Save
If w.Name <> ThisWorkbook.Name Then w.Close 'fermeture
Next
Application.Quit 'fermeture d'Excel
End Sub
'---réouverture des fichiers---
For Each s In Sheets
If Not ThisWorkbook.Name Like s.Name & ".xls*" Then _
Workbooks.Open chemin & s.Name & _
Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "."))
Next
Par inattention j'ai exécuté la macro sans spécifié le lieu d'enregistrement des fichiers, dans cas où les fichiers s'enregistrent t ils pas défaut ?
Sub CreerFichiers()
Dim chemin$, exten$, w As Workbook, s As Object
chemin = ThisWorkbook.Path & "\" 'à adapter
exten = Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "."))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next 'si caractères interdits pour les noms de fichiers
'---fermeture des fichiers ouverts---
For Each w In Workbooks
If w.Name <> ThisWorkbook.Name Then w.Close
Next
'---création des fichiers---
For Each s In Sheets
s.Visible = True 'sécurité
ThisWorkbook.SaveAs chemin & s.Name, ThisWorkbook.FileFormat
Next
'---réouverture des fichiers---
For Each s In Sheets
If ThisWorkbook.Name <> s.Name & exten Then _
Workbooks.Open chemin & s.Name & exten
Next
'---supression des feuilles---
For Each w In Workbooks
w.Activate 'pour Excel 2010
For Each s In w.Sheets
If w.Name <> s.Name & exten Then s.Delete
Next
w.Save
If w.Name <> ThisWorkbook.Name Then w.Close 'fermeture
Next
Application.Quit 'fermeture d'Excel
End Sub