Sub Sauvegarder()
Dim dossier$
dossier = ThisWorkbook.Path & "\TEST\" 'à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
MkDir dossier 'création du répertoire
On Error GoTo 0
Sheets("BD").Copy
With ActiveSheet
.DrawingObjects.Delete 'supprime les objets
.Columns("BG").Resize(, .Columns.Count - 58).Delete
.Parent.SaveAs dossier & Format(Date, "ddmmyy") & "_BD_W.xlsm", 52
.Parent.Close
End With
End Sub