Option Explicit
Sub Decoupage_2007()
Dim Wbk As Object
Dim Fso As Object
Dim sDossierClasseur As String, sNomDossier As String, sNomFichier As String
Dim Ws As Worksheet
Application.ScreenUpdating = False
sDossierClasseur = ThisWorkbook.Path
sNomDossier = Format(Date, "yyyymmdd")
Set Fso = CreateObject("Scripting.FileSystemObject")
If Fso.FolderExists(sDossierClasseur & "\" & sNomDossier) Then
Fso.DeleteFolder sDossierClasseur & "\" & sNomDossier, True
End If
Fso.CreateFolder sDossierClasseur & "\" & sNomDossier
Set Fso = Nothing
For Each Ws In ThisWorkbook.Worksheets
sNomFichier = "F_" & Ws.Name & "_" & Format(Date, "yyyymmdd") & ".xlsx"
ThisWorkbook.Worksheets(Ws.Name).Copy
Set Wbk = ActiveWorkbook
Application.DisplayAlerts = False
Wbk.SaveAs sDossierClasseur & "\" & sNomDossier & "\" & sNomFichier, xlOpenXMLWorkbook
Application.DisplayAlerts = True
Wbk.Close
Set Wbk = Nothing
Next Ws
Application.ScreenUpdating = True
End Sub