bonjour
j'emploie ce qui suit, commentaires inclus
'Sauvegarde automatique d'une feuille d'un classeur
'(Joël MAU, mpfe)
'A l'ouverture de ton classeur la feuille de nom 'MaFeuille',
'à modifier à ta convenance avec la valeur de la constante
'NomFeuilleACopier, est copiée dans un nouveau classeur
'Ce classeur est sauvegardé dans un dossier de Sauvegarde
'(par défaut ici le dossier 'SAUVEGARDES\\', crée dans le dossier courant,
'modifiable avec la const...DossierSauvegarde )
'Pour garder toutes les versions et les reconnaitre le nom du fichier de
'sauvegarde est constitué par le nom d'origine de ton classeur plus le jour
'est l'heure-Minutes du dernier enregistrement de ton classeur.
'Pour lancer l'opération à l'ouverture du classeur :
'====dans le module ThisWorkbook :
'Private Sub Workbook_Open()
' SauvegardeFeuille
'End Sub
'==================
'Puis A Mettre dans un module standard de ton classeur dont
'une feuille est à copier à chaque ouverture:
Public Const NomFeuilleACopier As String = 'NomFeuille'
Public Const DossierSauvegarde As String = 'G\\DossierSauvegarde'
Public Const sFormatDate As String = '''_''ddmmyy''_''hh''h''mm''mn'''
'attention notation americaine!!!
Sub SauvegardeFeuille()
Dim MaFeuille As Worksheet
Dim sPath As String, sFileSave As String
sPath = 'E:\\dossierFichier' 'ThisWorkbook.Path & '\\'
MsgBox ThisWorkbook.Name & ' ' & InfoDateModifFichier(ThisWorkbook.Name)
If FeuilleExiste(NomFeuilleACopier) Then
If Not FichierExiste(sPath & DossierSauvegarde) Then
' Dossier de sauvegarde inexistant
MkDir DossierSauvegarde ' sPath &
' crée le dossier de sauvegarde si inexistant
End If
sFileSave = sPath & DossierSauvegarde & NomFeuilleACopier & _
InfoDateModifFichier(ThisWorkbook.Name) & '.xls'
If Not FichierExiste(sFileSave) Then
' Le fichier n'existe pas déjà. Sinon pas besoin de resauvegarder
Worksheets(NomFeuilleACopier).Copy
ActiveWorkbook.SaveAs _
FileName:=sFileSave, FileFormat:=xlNormal, _
Password:='', WriteResPassword:='', _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close SaveChanges:=False
' Pas la peine de reenregistrer cela vient d'être fait!
End If
End If
Sheets(NomFeuilleACopier).Select
Range('E4:H58').ClearContents
'Range('D63
69').Select
' Selection.ClearContents
Range('D63
69').ClearContents
Range('J63:J69').ClearContents
Range('N4:N16').ClearContents
End Sub
Function FeuilleExiste(sName As Variant) As Boolean
' Teste si la feuille de nom 'sName' existe au niveau classeur
' Retourne vrai si existe!
On Error Resume Next
FeuilleExiste = False
FeuilleExiste = Not ActiveWorkbook.Sheets(sName) Is Nothing
Err.Clear
End Function
Function FichierExiste(sFile As Variant) As Boolean
' Teste si le fichier ou dossier (avec ou sans le \\ à la fin)
' de nom 'sFile' existe. Retourne vrai si existe!
Dim sProv As String
On Error GoTo Errorhandler
sProv = Dir(sFile, vbDirectory)
' vbDirectory est utile quand dossier vide car retourne '.' alors
FichierExiste = (sProv <> '')
Exit Function
Errorhandler:
MsgBox prompt:='Erreur sur test fichier= ' & sFile
End
End Function
Function InfoDateModifFichier(ByVal sFileIn As String) As String
' Retourne la date/heure de modification d'un fichier ,
'et si pas existant la date/heure actuelle
If FichierExiste(sFileIn) Then
InfoDateModifFichier = Format(FileDateTime(sFileIn), sFormatDate)
Else
InfoDateModifFichier = Format(Now, sFormatDate)
'jour et heure actuelle
End If
End Function
Application.Goto reference:='Essai'
Range('A1').Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Range('A1').Select
ActiveWorkbook.Save
à bientôt
