re
tu crées un bouton archivage dossier et tu y associes la macro ci-dessous, elle propose un nom et archive 1 feuille. Il faut créer un sous-répertoire ('Répertoire de stockage' dans mon exemple). J'ai considéré le N° en A1. C'est une adaptation d'un code que j'ai fait, si erreur dis-le-moi :
Sub sauvegarde()
nomfichier = ActiveWorkbook.Name
Application.ScreenUpdating = False
répertoire = ThisWorkbook.Path & '\\Répertoire de stockage'
nomfichier1 = 'Affaire ' & range('A1').value
'Proposition Nom de sauvegarde
ChDir (répertoire)
chemin = Application.GetSaveAsFilename(nomfichier1, 'Fichier Excel,*.xls')
If chemin = False Then Exit Sub
'création fichier 1 feuille
Workbooks.Add
nbfeuil = Sheets.Count
While nbfeuil > 1
Application.DisplayAlerts = False
ActiveSheet.Delete
nbfeuil = Sheets.Count
Application.DisplayAlerts = True
Wend
ActiveWorkbook.SaveAs Filename:=chemin
nomfichier1 = ActiveWorkbook.Name
'sauvegarde des données
Windows(nomfichier).Activate
derligne = Range('A65536').End(xlUp).Row
Range('A1:A' & derligne).EntireRow.Select
Selection.Copy
Windows(nomfichier1).Activate
Range('A1').Select
ActiveSheet.Paste
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range('A1').Select
Application.CutCopyMode = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Close savechanges:=True
'
Range('A1').Select
Application.ScreenUpdating = True
End Sub
A+
