Le code de Chip Pearson et Bob Umlas est bien connu pour une telle opération (je l'ai rappelé)
Toutefois, le classeur peut contenir des VALEURS que l'on veut ne PAS détruire
Ctte appli (sans prétention!) permet donc de conserver les valeurs existantes dans le classeur, mais détruit TOUT le reste :
Macros, bien sûr, mais aussi les formats, formules, etc...
Cette destruction partielle pourra être déclenchée par l'évènement de votre choix (une date limite par exemple), et SANS avertissement: Il convient en effet de ne pas faire état de cette "protection" supposée inconnue et "cachée" dans un ensemble de macros (les noms retenus pour les sub sont ici explicites : il conviendra de les changer par d'autres plus anodins).
Cela pourra compléter efficacement d'autres méthodes commme par exemple celle de bigfish_le vrai sur le forum :
http://www.vbfrance.com/codes/ASTUCE-AMELIORER-SECURITE-ACCES-DONNEES-CODE-FICHIER-EXCEL_48448.aspx
Source / Exemple :
'Dans le module "Suicider" :
Sub SuiciderSansTrace()
'Méthode 1
'Auto-détruire le Classeur et sa trace dans Documents Récents
'Références : Chip Pearson et Bob Umlas
Dim Hist As Integer
With ThisWorkbook
.Save
For Hist = 1 To Application.RecentFiles.Count
If Application.RecentFiles(Hist).Path = .FullName Then
Application.RecentFiles(Hist).Delete
Exit For
End If
Next Hist
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close SaveChanges:=False
Application.Quit
End With
End Sub
'------------------------------------------------------
Sub SuiciderSansTraceSaufValeurs()
'Méthode 2
'Ne conserve QUE LES VALEURS du Classeur à détruire et tue tout le reste
Dim ShNb As Integer, Sht As Integer, Hist As Integer
Dim WbFn As String, Wbn As String, TmpWbn As String, Shn As String
'Reprendre le chemin et nom du Classeur à détruire
WbFn = ThisWorkbook.FullName
'Reprendre le nom du Classeur à détruire
Wbn = ThisWorkbook.Name
'Créer un Classeur temporaire TmpWbn pour accueillir les données du Classeur à détruire
'Valeur initiale du Nombre de feuilles crées par l'application
ShNb = Application.SheetsInNewWorkbook
'Création du même nombre de feuilles que Classeur à détruire
Application.SheetsInNewWorkbook = Workbooks(Wbn).Sheets.Count
Set Newbook = Workbooks.Add
TmpWbn = ActiveWorkbook.Name
'Remise à la Valeur initiale dans l'application
Application.SheetsInNewWorkbook = ShNb
'Copier chaque feuille du Classeur à détruire dans le Classeur temporaire TmpWbn
For Sht = 1 To Workbooks(Wbn).Sheets.Count
Shn = Workbooks(Wbn).Sheets(Sht).Name
Workbooks(Wbn).Sheets(Sht).Cells.Copy
Workbooks(TmpWbn).Sheets(Sht).Cells.PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Workbooks(TmpWbn).Sheets(Sht).Name = Shn
Workbooks(TmpWbn).Sheets(Sht).Activate
Range("A1").Select
Next Sht
Application.CutCopyMode = False
'Renommer le Classeur à détruire puis le supprimer
Workbooks(Wbn).SaveAs Filename:="C:\Killed"
Kill WbFn
'Renommer le Classeur temporaire TmpWbn comme le Classeur détruit, l'enregistrer et le fermer (même chemin)
Workbooks(TmpWbn).SaveAs Filename:=WbFn
Workbooks(Wbn).Close SaveChanges:=True
'Détruire le Classeur (Références : Chip Pearson et Bob Umlas)
With ThisWorkbook
.Save
'Accessoirement : Supprimer l'historique du Classeur détruit
'------------------------------------------------------------
'For Hist = 1 To Application.RecentFiles.Count '
' If Application.RecentFiles(Hist).Path = .FullName Then '
' Application.RecentFiles(Hist).Delete '
' Exit For '
' End If '
'Next Hist '
'------------------------------------------------------------
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
End With
'Quitter
If Workbooks.Count < 2 Then
ThisWorkbook.Saved = True
Application.Quit
Else
ThisWorkbook.Close SaveChanges:=False
End If
End Sub
'-------------------------------------------------
'Dans "ThisWorkbook" :
Private Sub Workbook_Open()
'ATTENTION :
'Si vous décommentez ici, vous perdrez tout !
'Faites d'abord une sauvegarde !
'Exemple d'Auto-destruction du Classeur avec une Date au 1er Janvier 2013
'If Date > DateSerial(2013, 1, 1) Then
'Décommenter le mode choisi
'SuiciderSansTrace
'SuiciderSansTraceSaufValeurs
'Else
'Ouverture du Classeur autorisée
'Call ...
'MsgBox "..."
'End If
End Sub
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.