29.12.2010 um 12:01:47 Uhr

4043

Makros in vielen Excel Dokumenten finden

Eine Möglichkeit eine Auswertung durchzuführen, die mir alle Excel Dateien, die VBA / Markos enthalten auflistet.

Hallo zusammen,

ich habe in einem anderen Forum bereits einen Ansatz gefunden, der leider etwas veraltet ist (Office 2000).
Könnte man einem Anfänger vielleicht den Stoß in die richtige Richtung geben? Ich selbst benutze Office 2007

Option Explicit

Sub VbaCodeInDateienSuchen()
   Dim strStartOrdner As String, i As Long
   
   strStartOrdner = "E:\test"  
   
   With Application.FileSearch
      .NewSearch
      .FileType = msoFileTypeExcelWorkbooks
      .Filename = "*.xl?"  
      .LookIn = strStartOrdner
      .SearchSubFolders = True
      .Execute
      For i = 1 To .FoundFiles.Count
         Application.StatusBar = "Teste Datei " & i & " von " & .FoundFiles.Count  
         Cells(i, 1).Value = .FoundFiles(i)
         Cells(i, 2).Value = HasMacros(.FoundFiles(i))
      Next
      Application.StatusBar = False
   End With
End Sub

Private Function HasMacros(ByVal strFileName As String) As String
   Dim bHasCode As Boolean, bOpen As Boolean, vbc As Object
   On Error GoTo ERR_File
   
   bHasCode = False
   Application.EnableEvents = False
   Application.ScreenUpdating = False
   Workbooks.Open strFileName, UpdateLinks:=False, ReadOnly:=True, Password:="", WriteResPassword:="", AddToMru:=False  
   For Each vbc In ActiveWorkbook.VBProject.VBComponents
      If vbc.CodeModule.CountOfLines > 2 Then ' Option Explicit & eine Leerzeile lassen wir mal zu ...  
         bHasCode = True
         Exit For
      End If
   Next
   HasMacros = CStr(bHasCode)
   
ERR_File:
   If Err.Number Then HasMacros = Err.Description
   If Not ThisWorkbook Is ActiveWorkbook Then ActiveWorkbook.Close False
   Application.ScreenUpdating = True
   Application.EnableEvents = True
End Function 

Vielleicht hat jemand aber auch einen ganz anderen Ansatz?

Vielen Dank schonmal

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 157706

Url: https://administrator.de/forum/makros-in-vielen-excel-dokumenten-finden-157706.html

Ausgedruckt am: 23.02.2025 um 15:02 Uhr

14 Kommentare

Neuester Kommentar

Hallo djbazo!

Welches Betriebssystem?

Ab Windows 7 wird bei mir der Zugriff aus Sicherheitsgründen verweigert. Liegt womöglich an den Office-Sicherheits-Updates?

Gruß Dieter

PS. Mach mal testweise ein Kommentarzeichen vor das "On Error..."

Hallo Dieter,

danke für die Antwort. Setze VISTA Enterprise ein.

Bei mir kommt bei Ausführung:

Laufzeitfehler '445'
Objekt unterstützt diese Aktion nicht

-> den onError habe ich in Kommentar gesetzt

Hallo djbazo!

Und bleibt der Debugger in Codezeile 32 oder 33 stehen?

Gruß Dieter

Hallo Dieter,

er bleibt in Codezeile 8 mit dem Fehler stehen

Grüße

Hallo djbazo!

Habe ich wohl etwas geschlafen

Ab Version 2007 gibt es die Application FileSearch nicht mehr. Es gibt allerdings eine Alternative dazu, aber den Schnippsel muß ich erst suchen!

Gruß Dieter

Hallo djbazo!

Alternativ zu Application.FileSearch in etwa so:

Option Compare Text

Const StartFolder = "E:\Test"  'Hauptverzeichnis  

Dim Fso As Object

Sub Main
   '....  
    Set Fso = CreateObject("Scripting.FileSystemObject")  

    Call SearchExcelFiles(Fso.GetFolder(StartFolder))
   '....  
    MsgBox "Fertig!"  
End Sub

Private Sub SearchExcelFiles(ByRef Folder)  'Alle Dateien in Start- und Unterordner suchen  
    Dim File As Object, SubFolder As Object
    
    For Each File In Folder.Files
        If Fso.GetExtensionName(File.Name) Like "xl*" Then  
            Call OpenAndTestWorkbook(File.Path)
        End If
    Next
    
    For Each SubFolder In Folder.SubFolders
        Call SearchExcelFiles(SubFolder)
    Next
End Sub

Private Sub OpenAndTestWorkbook(ByRef Path)
   'Dein Workbook-Code  
End Sub

Gruß Dieter

danke, das läuft durch ohne Fehler.
jetzt muss ich nur noch die beiden Codes zusammenfriemeln verstehe ich das richtig (sorry - im a newby)

Hallo djbazo!

In meinem Code wird die "Sub OpenAndTestWorkbook" für jede gefundene Datei (Path ist Dateipfad) einzeln aufgerufen. Insofern kannst Du hier alles reinpacken

Der Makro-Start erfolgt dann über die Sub "Main" (Name nach belieben).

Den Zähler i musst Du allerdings in der Codezeile 5 mit definieren und in der Sub "Main" vor Codezeile 11 auf 1 setzen und in der Sub "OpenAndTestWorkbook" nach dem Eintrag in die entsprechenden Zellen hochzählen ( i = i +1) .

Gruß Dieter

Sorry Dieter - ich versteh gerade nur Bahnhof
Kannst du mir weiterhelfen, denn so klappts nicht:

Option Compare Text

Const StartFolder = "E:\Test"  'Hauptverzeichnis  

Dim Fso As Object

Sub Main
   '....  
    Set Fso = CreateObject("Scripting.FileSystemObject")  

    Call SearchExcelFiles(Fso.GetFolder(StartFolder))
   '....  
    MsgBox "Fertig!"  
End Sub

Private Sub SearchExcelFiles(ByRef Folder)  'Alle Dateien in Start- und Unterordner suchen  
    Dim File As Object, SubFolder As Object
    
    For Each File In Folder.Files
        If Fso.GetExtensionName(File.Name) Like "xl*" Then  
            Call OpenAndTestWorkbook(File.Path)
        End If
    Next
    
    For Each SubFolder In Folder.SubFolders
        Call SearchExcelFiles(SubFolder)
    Next
End Sub

Private Sub OpenAndTestWorkbook(ByRef Path)
   'Dein Workbook-Code  
   Dim bHasCode As Boolean, bOpen As Boolean, vbc As Object
   
   bHasCode = False
   Application.EnableEvents = False
   Application.ScreenUpdating = False
   Workbooks.Open strFileName, UpdateLinks:=False, ReadOnly:=True, Password:="", WriteResPassword:="", AddToMru:=False  
   For Each vbc In ActiveWorkbook.VBProject.VBComponents
      If vbc.CodeModule.CountOfLines > 2 Then ' Option Explicit & eine Leerzeile lassen wir mal zu ...  
         bHasCode = True
         Exit For
      End If
   Next
   HasMacros = CStr(bHasCode)
End Sub

Hallo djbazo!

Versuchs mal so:

Option Explicit
Option Compare Text

Const StartFolder = "E:\Test"  'Hauptverzeichnis  

Dim Fso As Object, FileCount As Long

Sub Start()
    Set Fso = CreateObject("Scripting.FileSystemObject")  

    FileCount = 1

    Call SearchExcelFiles(Fso.GetFolder(StartFolder))
    
    MsgBox "Fertig!"  
End Sub

Private Sub SearchExcelFiles(ByRef Folder)  'Alle Dateien in Start- und Unterordner suchen  
    Dim File As Object, SubFolder As Object
    
    For Each File In Folder.Files
        If Fso.GetExtensionName(File.Name) Like "xl*" Then  
            Call OpenAndTestWorkbook(File.Path)
        End If
    Next
    
    For Each SubFolder In Folder.SubFolders
        Call SearchExcelFiles(SubFolder)
    Next
End Sub

Private Sub OpenAndTestWorkbook(ByRef Path)
   Dim vbc As Object, MacroCode As Boolean
   
   With Application
        .EnableEvents = False
        .ScreenUpdating = False
   End With
   
   'On Error GoTo ERR_File  
   
   Workbooks.Open Path, UpdateLinks:=False, ReadOnly:=True
   
   For Each vbc In ActiveWorkbook.VBProject.VBComponents
     'Option Explicit & eine Leerzeile lassen wir mal zu ...  
      If vbc.CodeModule.CountOfLines > 2 Then MacroCode = True:  Exit For
   Next
   
ERR_File:
   If Not ThisWorkbook Is ActiveWorkbook Then ActiveWorkbook.Close False
   
   Cells(FileCount, 1).Value = Path

   If Err.Number Then
        Cells(FileCount, 2).Value = Err.Description
   Else
        Cells(FileCount, 2).Value = MacroCode
   End If

   FileCount = FileCount + 1
   
   With Application
        .ScreenUpdating = True
        .EnableEvents = True
   End With
End Sub

Gruß Dieter

Hallo Dieter,

noch ein gutes Neues.
Gleich zum Start auch noch so eine super Lösung die perfekt funktioniert.

Vielen Dank. Alle Daumen nach oben!!

Man kann sogar den Kommentar von On Error entfernen dann überspringt er sogar Dokumente mit geschützten Zellen....

Option Explicit
Option Compare Text

Const StartFolder = "E:\Test"  'Hauptverzeichnis  

Dim Fso As Object, FileCount As Long

Sub Start()
    Set Fso = CreateObject("Scripting.FileSystemObject")  

    FileCount = 1

    Call SearchExcelFiles(Fso.GetFolder(StartFolder))
    
    MsgBox "Fertig!"  
End Sub

Private Sub SearchExcelFiles(ByRef Folder)  'Alle Dateien in Start- und Unterordner suchen  
    Dim File As Object, SubFolder As Object
    
    For Each File In Folder.Files
        If Fso.GetExtensionName(File.Name) Like "xl*" Then  
            Call OpenAndTestWorkbook(File.Path)
        End If
    Next
    
    For Each SubFolder In Folder.SubFolders
        Call SearchExcelFiles(SubFolder)
    Next
End Sub

Private Sub OpenAndTestWorkbook(ByRef Path)
   Dim vbc As Object, MacroCode As Boolean
   
   With Application
        .EnableEvents = False
        .ScreenUpdating = False
   End With
   
   On Error GoTo ERR_File
   
   Workbooks.Open Path, UpdateLinks:=False, ReadOnly:=True
   
   For Each vbc In ActiveWorkbook.VBProject.VBComponents
     'Option Explicit & eine Leerzeile lassen wir mal zu ...  
      If vbc.CodeModule.CountOfLines > 2 Then MacroCode = True:  Exit For
   Next
   
ERR_File:
   If Not ThisWorkbook Is ActiveWorkbook Then ActiveWorkbook.Close False
   
   Cells(FileCount, 1).Value = Path

   If Err.Number Then
        Cells(FileCount, 2).Value = Err.Description
   Else
        Cells(FileCount, 2).Value = MacroCode
   End If

   FileCount = FileCount + 1
   
   With Application
        .ScreenUpdating = True
        .EnableEvents = True
   End With
End Sub

DANKE!!

Hallo djbazo!

Yepp, gern geschehen

Wünsche auch ein gutes neues Jahr!

Gruß Dieter

Hallo Dieter,

nun ist mir doch noch etwas aufgefallen.
Sobald eine Datei einen Leseschutz hat kommt die Passwortabfrage.
Diese breche ich generell ab und überspringe somit die Datei.

Hast du einen kleinen Kniff, wie das per Script umgesetzt werden kann?

Grüße

Hallo djbazo!

Sollte so gehen:

'Snip......................................  

Private Sub OpenAndTestWorkbook(ByRef Path)
   Dim vbc As Object, MacroCode As Boolean
   
   With Application
        .EnableEvents = False
        .ScreenUpdating = False
   End With
   
   On Errror Resume Next    'Fehlerbehandlung deaktivieren  

   Workbooks.Open Path, UpdateLinks:=False, ReadOnly:=True
   
   If Err.Number = 0 Then  
       For Each vbc In ActiveWorkbook.VBProject.VBComponents
         'Option Explicit & eine Leerzeile lassen wir mal zu ...  
          If vbc.CodeModule.CountOfLines > 2 Then MacroCode = True:  Exit For
       Next
   
       ActiveWorkbook.Close False
   
       Cells(FileCount, 2).Value = MacroCode
   Else
       Cells(FileCount, 2).Value = Err.Description:  
   End If	   
    
  'On Error Goto 0      
  'Würde die Fehlerbehandlung für den Rest-Code bis End Sub wieder aktivieren  
   
   Cells(FileCount, 1).Value = Path

   FileCount = FileCount + 1
   
   With Application
        .ScreenUpdating = True
        .EnableEvents = True
   End With
End Sub

Gruß Dieter

gelöst Frage Microsoft Microsoft Office

Mehr von djbazo

VBS Dateiauswahl klappt nicht bei jeder Endung (ShellApp.BrowseForFolder)djbazo - 9 Kommentare

Serverablöse - neuen und alten Server mit gleicher IP Adresse im Netz betreibendjbazo - 13 Kommentare

Slipstream RSAT in W7 CDdjbazo - 2 Kommentare

W7 Updateverlauf exportieren oder anzeigendjbazo - 3 Kommentare

Heiß diskutiert