XL 2016 supprimer 1 ou tous les modules vba

[Usine à gaz]

Bonjour à toutes et à tous,

Élucubrations du dimanche matin et encore besoin de vos lumières

Je reprends tous mes classeurs qui contiennent bcp de codes tous venus du forum
et adaptés selon mes petites connaissances.
Un grand à vous toutes et tous car sans vous, je n'aurais pas pu travailler dans de bonne conditions.

J'ai besoin pour tout reprendre et nettoyer plus vite d'un code supprimant d'un coup tous les modules du classeur ouvert.
Ne sachant pas faire cela, j'ai beaucoup cherché cette nuit sur le net.
Tout ce que j'ai pu essayer et/ou tenter d'adapter n'a pas pas réussi.

Les codes qui me semblent les plus proches sont ceux du site : https://silkyroad.developpez.com/VBA/VisualBasicEditor/#LIV-D
Mais les 2 codes que j'ai récupéré 'coincent" chez moi et je n'arrive pas à modifier pour que ça fonctionne :

Sub supprimerUnModule()
    With ThisWorkbook.VBProject.VBComponents
        .Remove .Item("Module2")
    End With
End Sub

Sub SupprimeTout()
    'supprime la totalité des procédures
    Dim VbComp As VBComponent

    For Each VbComp In ThisWorkbook.VBProject.VBComponents
        Select Case VbComp.Type
            Case 1 To 3
                ThisWorkbook.VBProject.VBComponents.Remove VbComp
            Case Else
                With VbComp.CodeModule
                .DeleteLines 1, .CountOfLines
                End With
        End Select
    Next VbComp
End Sub

Si vous aviez la solution, ça me ferait gagner beaucoup de temps.
Je joins un fichier test.
Avec mes remerciements,
Je vous souhaite à toutes et à tous un beau dimanche,
Amicalement,
lionel,

 

[Usine à gaz]

LOL pour un fil qui n'aurait pas du exister c'est pas mal

 

[Usine à gaz]

OUI Gérard, c'est bon ça marche maintenant.
Encore un grand merci

 

[Usine à gaz]

Bonjour Gérard, le Forum,

Tous comptes faits, je vais choisir le code d'enregistrement en xlsx de Gérard :

Private Sub Workbook_Open()
If Date >= DateSerial(2017, 9, 1) Then  'Choisir la date de fin applicatif
  Dim Sh As Object, s As Shape, fn$
  For Each Sh In Me.Sheets
    If Sh.ProtectContents Then Sh.Protect "0000", UserInterfaceOnly:=True
    For Each s In Sh.Shapes
      If s.OnAction <> "" Then s.Delete
  Next s, Sh
  Application.DisplayAlerts = False
  fn = Me.FullName
  Me.SaveAs Left(fn, InStrRev(fn, ".") - 1), 51
  Kill fn
  Workbooks.Open Me.FullName
End If
Me.Sheets("Recp").Activate
End Sub

Comme dans un xlsx = pas de code,
Je ne vois pas comment faire lui demander de se fermer automatiquement à la fin de l'exécution du code.

Auriez-bous la solution ?
Avec mes remerciements,
Bonne journée à toutes et à tous,
Amicalement,
lionel,

 

[job75]

Je ne vois pas comment faire lui demander de se fermer automatiquement à la fin de l'exécution du code.

Remplacer :

Workbooks.Open Me.FullName

par :

ThisWorkbook.Close

 

[Usine à gaz]

Bonjour Gérard,

Merci d'être encore et toujours là
Et merci pour le code remplacement
Bonne journée,
lionel,

 

[job75]

par :

ThisWorkbook.Close

Ceci sera mieux :

If Workbooks.Count = 1 Then Application.Quit Else ThisWorkbook.Close

 

[Usine à gaz]

Vraiment merci Gérard pour tant de gentillesse et de précision

 

[Usine à gaz]

Bonjour Gérard, le Forum,

Vraiment désolé de revenir sur le sujet mais j'ai une erreur 9 que je n'arrive pas à modifier.
je cherche et j'ai trouvé bcp d'explications sur le forum et sur le net mais je n'arrive pas à les comprendre.
Voici le code :

If Sheets("Introduction").[p1] < Now Then
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Object, s As Shape, fn$
  For Each Sh In Me.Sheets
    If Sh.ProtectContents Then Sh.Protect "0000", UserInterfaceOnly:=True
    For Each s In Sh.Shapes
      If s.OnAction <> "" Then s.Delete
  Next s, Sh
  Application.DisplayAlerts = False
  fn = Me.FullName
  Me.SaveAs Left(fn, InStrRev(fn, ".") - 1), 51
  Kill fn
    If Workbooks.Count = 1 Then
    Application.Quit
    Else: ThisWorkbook.Close
    End If
    Application.DisplayAlerts = False

    Me.Sheets("Recp").Activate
End If

Je joins également la photo de l'erreur.

Un dernier petit coup d'aide ?
Un grand merci,
Amicalement,
lionel,

 

[Usine à gaz]

Re-Bonjour Gérard, toutes et tous,

A forces d'essais, j'ai réussi (me semble-t-il) à résoudre le problème.

J'ai juste ajouté "exit sub" et les tests fonctionnent sans message "d'erreur".
Je joins le code qui semble fonctionner :

If Sheets("Introduction").[p1] < Now Then
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Object, s As Shape, fn$
  For Each Sh In Me.Sheets
    If Sh.ProtectContents Then Sh.Protect "0000", UserInterfaceOnly:=True
    For Each s In Sh.Shapes
      If s.OnAction <> "" Then s.Delete
  Next s, Sh
  Application.DisplayAlerts = False
  fn = Me.FullName
  Me.SaveAs Left(fn, InStrRev(fn, ".") - 1), 51
  Kill fn
    If Workbooks.Count = 1 Then
    Application.Quit
    Else: ThisWorkbook.Close
    End If
    Application.DisplayAlerts = False
    exit sub
    Me.Sheets("Recp").Activate
End If

Bonne journée à toutes et à tous,

 

[eriiic]

Bonjour,

drôle de façon de 'réparer'...
Supprime la ligne

 Me.Sheets("Recp").Activate

ou mieux : enlève le Me et contrôle ton nom de feuille...
Et si tu veux activer une feuille, il faut le faire avant le . Close
eric

 

[Usine à gaz]

Bonjour,

Merci pour les rectification de ma correction bizarre
lionel,

 

[Staple1600]

Bonsoir le fil,

Re

Pour supprimer rapidement tout le vba, d'un classeur, c'est très simple
Il suffit de l'enregister en *.xlsx
Donc pour traiter N fichiers d'un répertoire, il suffit de créer une macro qui enregistre en *.xlsx
Et pour faire cela, il y a déjà tout ce qu'il faut sur XLD

Sur XLD et dans mes archives sur mon HD
Donc voici une macro qui fait ce que j'évoquais dans les message#4...

Sub Conversion_Vers_XLSX()
Dim FSO As Object, fFile As Object, fFolder As Object, strConversionPath$, wkbConvert As Workbook
' Choix du dossier
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False: .Show: strConversionPath = .SelectedItems(1)
End With
With CreateObject("Scripting.FileSystemObject")
    If .FolderExists(strConversionPath) Then
        Set fFolder = .GetFolder(strConversionPath)
        ' Boucle sur le dossier pour chercher *.xlsm ou *.xlsb
        For Each fFile In fFolder.Files
            If Right(fFile.Name, 5) = ".xlsm" Or Right(fFile.Name, 5) = ".xlsb" Then
                Application.DisplayAlerts = False
                Set wkbConvert = Workbooks.Open(fFile.Path)
                ' Sauvegarde en *.xlsx
                wkbConvert.SaveAs .BuildPath(fFile.ParentFolder, Left(fFile.Name, InStrRev(fFile.Name, ".") - 1)) & ".xlsx", FileFormat:=51
                wkbConvert.Close SaveChanges:=False
                'Suppresion du fichier original
                fFile.Delete Force:=True
                Application.DisplayAlerts = True
            End If
        Next fFile
    End If
    End With
    'adapté de [N.Perkins|281212|(0)(0)29166]
End Sub

NB: Le classeur contenant la macro ne doit pas se trouver dans le dossier où sera opéré la conversion en *.xlsx

 

[Staple1600]

Re

arthour973
Merci pour le j'aime mais le plus important serait de savoir si mon code fonctionne sur ton PC.
Tu as testé?

 

[Usine à gaz]

Re,
Pas encore car je suis en train de préparer un travail pour demain matin.
J'essaierai ce soir si je ne suis pas "mort" LOl.
Sinon promis, je teste demain à la "presque" 1ère heure

 

[Staple1600]

Re

1) Je créé un dossier
2) J'y copie trois classeurs: deux classeurs *.xslm et un classeur *.xlsb
3) Je copie le code VBA du message#42 dans un classeur vierge non enregistré
4) Je lance la macro
C'est que j'ai fait avant de poster ma macro et cela m'a pris moins de 3 minutes...