Alle Makros durch Makro löschen
08.11.2014 11:35:30
Daniel
ich glaube bei meinem letzten Thread ist etwas schief gegangen also probiere ich es hier noch einmal.
Wir benutzen Dateien die über lange Jahre entwickelt wurden und in denen eine Menge ungenutzter Makros liegen die ich gerne entfernen möchte. (Ich glaube das diese ev. Instabilitäten/Abstürze verursachen)
Nun habe ich ein Makro gefunden das alle Makros in einer Datei löscht (s.u.) aber das wir sehr viele Dateien haben würde ich dieses gerne nutzen um alle Makros von allen Dateien in einem zu wählenden Ordner löscht. Am besten mit einem Auswahlmenue für den Ordner. Diese würde ich in meiner Personal.xlsb unterbringen und bei Bedarf die Dateien in dem entsprechenden Ordner bereinigen.
ich habe jetzt noch etwas code gefunden von dem ich gehofft habe das er das erfüllen kann was ich mir vorstelle. In diesen habe ich den code (kursiv) zum löschen der Makros sowie eine box zum Pfad eingeben eingefügt.
Die erste Fehlermeldung die ich bekomme is die "Methode calculation für das Objekt_Application" ist fehlgeschlagen. wenn ich dieses einfach mal ausschalte mit ' passiert gar nix mehr... Folgerung er hat nen Fehler und führt "fin" aus. Also das abgeschaltet dann kommt typen unverträglich für stCalc = .Calculation.
Zu allem überfluss führt er das zweite sub gar nicht in den Makros auf... keine Ahnung warum...
Hier bin ich leider völlig überfordert.
Ich hoffe Ihr könnt mir hier Helfen!!
Option Explicit
' Suchmuster gegebenenfalls anpassen
Const strEX As String = "*.xls*"
' Module : Module1
' Procedure : Files_Read
' Author : Case (Ralf Stolzenburg)
' Date : 15.10.2012
' Purpose : Alle Dateien eines Ordners - Optional mit Unterordner...
Sub Files_Read()
Dim stCalc As Integer
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
Dim dirInfo As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Datei im gleichen Ordner wie Auswertungsdateien
' strDir = ThisWorkbook.Path & "\"
' Fester Ordner vorgegeben
strDir = InputBox("Text ?", "Title") 'Verzeichniss pfad eingabe
strDir = IIf(Right(strDir, 1) "\", strDir & "\", strDir)
Set objDir = objFSO.getfolder(strDir)
'dirInfo objDir, strEX, True ' Mit Unterordner
dirInfo objDir, strEX, False ' Ohne Unterordner
Fin:
With Application
' Bei Bedarf
'.Goto (ThisWorkbook.Worksheets(1).Range("A1")), True
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
End Sub
' Module : Module1
' Procedure : dirInfo
' Author : Case (Ralf Stolzenburg)
' Date : 15.10.2012
' Purpose : Rekursive Funktion alle Dateien...
Sub MakroDel(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName Then
If varTMP.Name ThisWorkbook.Name Then
If Left(varTMP.Name, 1) "~" Then
' Hier jetzt der Code um mit der Datei etwas zu machen
' z. B. Öffnen, etwas auslesen oder was auch immer...
' Im folgenden werden nur ein paar Informationen
' im Direktfenster (VBE - STRG+G) ausgegeben
' Diese Zeilen mit Debug.Print können natürlich
' gelöscht bzw. auskommentiert werden
'alle Module löschen
Set VB = Application.VBE.ActiveVBProject
For Each Objekt In ThisWorkbook.VBProject.vbComponents
If Objekt.Type = 1 Then VB.vbComponents.Remove _
VB.vbComponents(Objekt.Name)
Next Objekt
End If
End If
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, blnTMP
Next varTMP
End If
End Sub
Anzeige
