djbazo
Dec 29, 2010
view3938
view14
0
Goto Top

Makros in vielen Excel Dokumenten finden

GermansolvedQuestionMicrosoft OfficeMicrosoft

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
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 157706

Url: https://administrator.de/contentid/157706

Printed on: April 24, 2024 at 00:04 o'clock

14 Comments
Latest comment
Goto Top
Mitglied: 76109
76109 Dec 29, 2010 at 11:30:56 (UTC)
Goto Top
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..."
Member: djbazo
djbazo Dec 29, 2010 at 12:52:44 (UTC)
Goto Top
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
Mitglied: 76109
76109 Dec 29, 2010 at 13:19:54 (UTC)
Goto Top
Hallo djbazo!

Und bleibt der Debugger in Codezeile 32 oder 33 stehen?

Gruß Dieter
Member: djbazo
djbazo Dec 29, 2010 at 13:44:04 (UTC)
Goto Top
Hallo Dieter,

er bleibt in Codezeile 8 mit dem Fehler stehen

Grüße
Mitglied: 76109
76109 Dec 29, 2010 at 13:47:58 (UTC)
Goto Top
Hallo djbazo!

Habe ich wohl etwas geschlafenface-wink

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
Mitglied: 76109
76109 Dec 29, 2010 at 14:08:18 (UTC)
Goto Top
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
Member: djbazo
djbazo Dec 29, 2010 at 14:40:40 (UTC)
Goto Top
danke, das läuft durch ohne Fehler.
jetzt muss ich nur noch die beiden Codes zusammenfriemeln verstehe ich das richtig (sorry - im a newby)
Mitglied: 76109
76109 Dec 29, 2010 at 14:58:14 (UTC)
Goto Top
Hallo djbazo!

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

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
Member: djbazo
djbazo Dec 29, 2010 at 15:10:37 (UTC)
Goto Top
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
Mitglied: 76109
76109 Dec 29, 2010 at 15:56:06 (UTC)
Goto Top
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
Member: djbazo
djbazo Jan 03, 2011 at 14:22:40 (UTC)
Goto Top
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!!
Mitglied: 76109
76109 Jan 03, 2011 at 14:52:15 (UTC)
Goto Top
Hallo djbazo!

Yepp, gern geschehenface-wink

Wünsche auch ein gutes neues Jahr!

Gruß Dieter
Member: djbazo
djbazo Jan 04, 2011 at 12:32:28 (UTC)
Goto Top
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
Mitglied: 76109
76109 Jan 04, 2011 at 14:55:14 (UTC)
Goto Top
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
GermansolvedQuestionMicrosoft OfficeMicrosoft
Hotly discussed
gleixnerdCheck of ZFW Firewallgleixnerd - 5 CommentsjstrickerWireguard VPN on UDM Pro behind Fritzbox - Handshake did not completejstricker - 3 CommentsAlexWishaHow to set up and configure a Linux GRE tunnelAlexWisha - 3 Comments