Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
(ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
Sub CreationDossier(sNomRep As String)
SHCreateDirectoryEx 0&, sNomRep, 0&
End Sub
Sub CreateFolder()
Dim Rep As String, Nom As String
On Error Resume Next
Nom = Format(Date, "yyyy_mm_dd")
Rep = "C:\Users\" & Environ("username") & "\Desktop\" & Nom
CreationDossier Rep
Application.Wait (Now + TimeValue("00:00:01"))
Call SaveSheets
End Sub
Sub SaveSheets()
Dim Wsh, Chemin, Rep, Nm As String, x As Integer, Ws As Worksheet, sh
Set Wsh = CreateObject("WScript.Shell")
Nm = Format(Date, "yyyy_mm_dd")
Chemin = Wsh.SpecialFolders("Desktop") & "\" & Nm & "\"
For Each Ws In Worksheets
Ws.Activate
Ws.SaveAs Filename:= _
Chemin & Ws.Name & ".xls", _
FileFormat:=xlExcel8, CreateBackup:=False
'Si il y à des boutons, sinon à enlever
For Each sh In Ws.Shapes
If sh.Type = 8 Then sh.Delete
Next sh
Next Ws
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.Quit
End Sub