AW: Makros durch Makro löschen für Verzeichniss
08.11.2014 10:03:21
Daniel
Hallo zusammen,
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 obigen code (kursiv) 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